การส่งข้อมูลข้ามชีทด้วย Vba

[Ueng999]

สวัสดีค่ะรบกวนช่วยดู code สำหรับการส่งข้อมูลข้ามชีทค่ะ มีตัวอย่างให้ดูหรือช่วยแนะนำการวาง code ด้วยค่ะ
ลำดับขันตอนการทำงาน คลิก Button1 จะมีฟอร์มให้กรอกเวลา
การทำงานที่ 1 จะขึ้นวันที่และเวลา ที่เซลล์ที่มีค่าตรงกับเซลล์ A2
การทำงานที่ 2 จะขึ้นเวลาที่พิมพ์ใน Form ที่เซลล์ที่มีค่าตรงกับเซลล์ A2
การทำงานที่ 3 ต้องการให้เวลาที่พิมพ์ใน Form จากไฟล์แนบคือ 10:00 ให้ขึ้นที่ Sheet2และSheet3 เซลล์เดียวกับ Sheet1 ด้วยค่ะ
ลองใส่ Code เองแล้ว(หลายรอแล้วค่ะ) ตอนนี้ใช้เป็นสูตรอยู่ สูตรเยอะค่ะทำให้ทำงานช้า ต้องการวิธีวาง code VBA ท่านผู้ไดทราบช่วยบอกที่ค่ะ

[snasui]

ลองดูตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Private Sub CommandButton1_Click()
    Dim r As Range
    Dim x As String
    For Each r In Range("A3", Range("A" & Rows.Count) _
        .End(xlUp))
            If r = Range("a2") Then r.Offset(0, 4) = Now
            If r = Range("a2") Then
                x = r.Offset(0, 6).Address
                r.Offset(0, 6) = TextBox1.Text
                Sheets("Sheet2").Range(x) = TextBox1.Text
                Sheets("Sheet3").Range(x) = TextBox1.Text
            End If
    Next r
    Unload Me
End Sub

[Ueng999]

ลองปรับ Code ตามที่บอกแล้วค่ะ ขอบคุณมากมากเลยค่ะ

[Ueng999]

ติดปัญหาค่ะ Sheet มีการ protect ไว้ทุกSheet พอใส่ Code เพื่อ protect Sheet Code ก็ใช้ไม่ได้ไม่ทราบว่าต้องปรับตรงไหนค่ะ รบกวนอีกครั้งค่ะ

Code: Select all

Private Sub cmdOK2_Click()
ThisWorkbook.Unprotect Password:="1"
     Dim r As Range
    Dim x As String
    For Each r In Range("A3", Range("A" & Rows.Count) _
        .End(xlUp))
             If r = Range("a2") Then r.Offset(0, 4) = Now
                   If r = Range("a2") Then
                x = r.Offset(0, 6).Address
                r.Offset(0, 6) = TextBox1.Text
                             Sheets("Time1").Range(x) = TextBox1.Text
                             Sheets("Time3").Range(x) = TextBox1.Text
                             Sheets("Time4").Range(x) = TextBox1.Text
                             Sheets("Time5").Range(x) = TextBox1.Text
                           End If
    Next r
ThisWorkbook.Protect Password:="1"
    ThisWorkbook.Save
        Unload Me
End Sub

[snasui]

ช่วยจับภาพ Error หรืออธิบายมาว่า Error ขึ้นว่าอย่างไรครับ

[Ueng999]

ขึ้นแถบสีเหลืองตรง

Code: Select all

r.Offset(0, 4) = Now

[snasui]

แสดงว่าการปลดการป้องกันไม่ทำงาน ลองกด F8 ซ้ำ ๆ จนเลยบรรทัด ThisWorkbook.Unprotect Password:="1" จากนั้นกลับไปยัง Excel แล้วตรวจสอบดูว่ามีการปลดการป้องกันแล้วหรือไหม่ หาก Code ถูกต้องย่อมที่จะต้องปลดการป้องกันให้แล้ว

ปกติการปลดการป้องกันชีท จะต้องปลดการป้องกันเป็น Sheet ดังนั้น Code ควรจะเป็น ActiveSheet.Unprotect Password:="1"

[Ueng999]

ลองทำตามแล้วยังไม่ได้ค่ะลองส่งไฟล์มาให้ช่วดูค่ะ

Code: Select all

 ActiveSheet.Unprotect Password:="1"
     Dim r As Range
    Dim x As String
    For Each r In Range("A3", Range("A" & Rows.Count) _
        .End(xlUp))
             If r = Range("a2") Then r.Offset(0, 4) = Now
                   If r = Range("a2") Then
                x = r.Offset(0, 6).Address
                r.Offset(0, 6) = TextBox1.Text
                         Sheets("Time2").Range(x) = TextBox1.Text       
                         Sheets("Time3").Range(x) = TextBox1.Text
                             End If
        Next r
    ActiveSheet.Protect Password:="1"
    ThisWorkbook.Save
        Unload Me

[snasui]

ไฟล์ที่แนบมาไม่มีชีท Time2, Time3 ครับ เปลี่ยนชื่อชีทให้เป็นตามใน Code หรือเปลี่ยน Code ให้อ้างถึงชีทที่มีอยู่จริงครับ

[Ueng999]

ขอโทษค่ะ เปลี่ยนข้อมูลแล้วค่ะ ขึ้น Run-time error "1004": ค่ะ แนบไฟล์ให้ใหม่ค่ะ ขึ้นแถบสีเหลืองที่ code

Code: Select all

Sheets("Time2").Range(x) = TextBox1.Text

[niwat2811]

แบบนี้ใช้ได้ตามต้องการไหมครับ

Code: Select all

Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim pwd As String
Dim r As Range
Dim x As String
pwd = "1"
For Each ws In Worksheets
    ws.Unprotect Password:=pwd
Next ws
For Each r In Range("A3", Range("A" & Rows.Count).End(xlUp))
    If r = Range("a2") Then r.Offset(0, 4) = Now
        If r = Range("a2") Then
            x = r.Offset(0, 6).Address
                r.Offset(0, 6) = TextBox1.Text
                Sheets("Time2").Range(x) = TextBox1.Text
                Sheets("Time3").Range(x) = TextBox1.Text
        End If
Next r
For Each ws In Worksheets
    ws.Protect Password:=pwd
Next ws
    ThisWorkbook.Save
    Unload Me
End Sub

[Ueng999]

ได้แล้วค่ะขอบคุณมากมากนะค่ะ

[Ueng999]

รบกวนเพิ่มเติมค่ะ
ลำดับขันตอนการทำงาน คลิก Button2 จะมีฟอร์มให้กรอกเวลา
การทำงานที่ 1 จะขึ้นวันที่และเวลา ที่เซลล์ที่มีค่าตรงกับเซลล์ A2 ที่ชีท Time1,Time2,Time3
การทำงานที่ 2 จะขึ้นเวลาที่พิมพ์ใน Form Time2 เซลล์ที่มีค่าตรงกับเซลล์ A2 ที่ชีท Time1,Time2,Time3 Renge("G")
การทำงานที่ 3 จะขึ้นเวลาที่พิมพ์ใน Form Time3 เซลล์ที่มีค่าตรงกับเซลล์ A2 ที่ชีท Time1,Time2,Time3 Renge("H")

Code: Select all

Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim pwd As String
Dim r As Range
Dim x As String
pwd = "1"
For Each ws In Worksheets
    ws.Unprotect Password:=pwd
Next ws
For Each r In Range("A3", Range("A" & Rows.Count).End(xlUp))
    If r = Range("a2") Then
       x = r.Offset(0, 4).Address
                r.Offset(0, 4) = Now
                Sheets("Time2").Range(x) = Now
                Sheets("Time3").Range(x) = Now
        If r = Range("a2") Then
            x = r.Offset(0, 6).Address
                r.Offset(0, 6) = TextBox1.Text
                Sheets("Time2").Range(x) = TextBox1.Text
                Sheets("Time3").Range(x) = TextBox1.Text
        If r = Range("a2") Then
            x = r.Offset(0, 7).Address
                r.Offset(0, 7) = TextBox2.Text
                Sheets("Time2").Range(x) = TextBox2.Text
                Sheets("Time3").Range(x) = TextBox2.Text
        End If
                Next
For Each ws In Worksheets
    ws.Protect Password:=pwd
Next ws
    ThisWorkbook.Save
    Unload Me
End Sub

ขึ้นแถบสีฟ้าตรง

Code: Select all

Next r

[Ueng999]

ส่งไฟล์แนบเพิ่มมาให้ค่ะ

[snasui]

ลองดูตัวอย่าง Code ตามด้านล่างครับ

Code: Select all

Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim pwd As String
    Dim r As Range
    Dim x0 As String
    Dim x1 As String
    Dim x3 As String
    pwd = "1"
    For Each ws In Worksheets
        ws.Unprotect Password:=pwd
    Next ws
    For Each r In Range("A3", Range("A" & Rows.Count).End(xlUp))
        If r = Range("a2") Then
           x0 = r.Offset(0, 4).Address
           x1 = r.Offset(0, 6).Address
           x2 = r.Offset(0, 7).Address
            r.Offset(0, 4) = Now
            Sheets("Time2").Range(x0) = Now
            Sheets("Time3").Range(x0) = Now
            Sheets("Time2").Range(x1) = TextBox1.Text
            Sheets("Time3").Range(x1) = TextBox1.Text
            Sheets("Time2").Range(x2) = TextBox2.Text
            Sheets("Time3").Range(x2) = TextBox2.Text
        End If
    Next r
    For Each ws In Worksheets
        ws.Protect Password:=pwd
    Next ws
    ThisWorkbook.Save
    Unload Me
End Sub

[Ueng999]

ขอบคุณ ขอบคุณมากค่ะ