ใช้ vba Source and Copy

[Totem]

เรียนอาจารย์และเพื่อนสมาชิก

การค้นหาและคัดลอก โดยมาหลักดังนี้
ต้องการให้หารายการในช่อง H2:H7
เมื่อข้อมูลตรงกับในช่อง A2:A20
ให้คัดลอกรายการในช่อง I2:I7
ไปวางไว้ในช่อง E2:E20
ตัวอย่าง เช่น รายการ aa ในช่อง H1 ตรงกับช่อง A2 , A4 ให้นำรายการในช่อง I2 คือ กก1 คัดลอกไปวางไว้ในช่อง E2 , E5 เป็นต้น
ค้นหาแบบนี้จนครบทุกรายการในช่อง H2 : H7
code นี้ ผมศึกษาจะกระทู้อื่นใน web นี้ จะนำไปปรับใช้แล้ว ติดปัญหา ขอให้ช่วยปรับ code vba ครับ

Code: Select all

    Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Sheets("data")
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 4) = .Range("I2", .Range("I" & Rows.Count).End(xlUp))
        Next rt
    Next rs
    
    Exit Sub
    
    End Sub

ติดตรงบรรทัดนี้ครับ

Code: Select all

 If rt = rs Then rt.Offset(0, 4) = .Range("I2", .Range("I" & Rows.Count).End(xlUp))

ขอความกระจ่างครับ

ขอบคุณครับ

SourceAndCopy.xlsm

(15 KiB) Downloaded 20 times

[snasui]

จะนำไปปรับใช้แล้ว ติดปัญหา ขอให้ช่วยปรับ code vba ครับ

คำว่าจะนำไปปรับใช้ ไม่ถือว่าปรับมาแล้ว ลองปรับที่ผมระบายสีมาเองก่อน ติดแล้วแจ้งมาอีกทีครับ

Set rSource = .Range("H2", .Range("[color=#FF4000]A[/color]" & Rows.Count).End(xlUp)) กับ
= [color=#FF4000].Range("I2", .Range("I" & Rows.Count).End(xlUp))[/color]

[Totem]

จะนำไปปรับใช้แล้ว ติดปัญหา ขอให้ช่วยปรับ code vba ครับ

คำว่าจะนำไปปรับใช้ ไม่ถือว่าปรับมาแล้ว ลองปรับที่ผมระบายสีมาเองก่อน ติดแล้วแจ้งมาอีกทีครับ

Set rSource = .Range("H2", .Range("[color=#FF4000]A[/color]" & Rows.Count).End(xlUp)) กับ
= [color=#FF4000].Range("I2", .Range("I" & Rows.Count).End(xlUp))[/color]

ได้ลองปรับแล้วแต่ยังไม่ตรงตามที่ต้องการครับ ยังไม่สามารถคัดลอกเรียงลำดับตามรายการในช่อง I2 : I5 ได้เป็น กก1 ทุกช่องในคอลัมน์ E2:E6 , E14,E19

Code: Select all

    Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("H" & Rows.Count).End(xlUp))
    End With
    With Sheets("data")
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 4) = Range("I2", Range("I2").End(xlDown)).Rows.Value
        Next rt
    Next rs
    
    Exit Sub
    
    End Sub

[DhitiBank]

เกือบได้แล้วครับ ลองปรับโค้ดเป็นแบบนี้ครับ

Code: Select all

Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("H" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
        For Each rs In rSource
            For Each rt In rTarget
                If rt = rs Then rt.Offset(0, 4) = rs.Offset(0, 1)
            Next rt
        Next rs
End Sub

[bank9597]

Dim rSource As Range
Dim rTarget As Range
Dim rs As Range
Dim rt As Range

With Sheets("data")
Set rSource = .Range("H2", .Range("h" & Rows.Count).End(xlUp))
Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

For Each rt In rtarget
For Each rs In rsource
If rt = rs Then
rt.Offset(0, 4)=rs.offset(0,1)
End if
Next rs
Next rt

ผมตอบผ่านสมาร์โฟน ลองดูครับ

[Totem]

เกือบได้แล้วครับ ลองปรับโค้ดเป็นแบบนี้ครับ

Code: Select all

Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("H" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
        For Each rs In rSource
            For Each rt In rTarget
                If rt = rs Then rt.Offset(0, 4) = rs.Offset(0, 1)
            Next rt
        Next rs
End Sub

ตอนแรกผมปรับเป็น

Code: Select all

If rt = rs Then rt.Offset(0, 4) = rs.Offset(0, 8)

เลยเป็นค่าว่าง ผมยังสับสนกับ Offset ตรง column ว่าจะต้องอยู่ตรงตำแหน่ง 8 คือ I2:I8 เพราะเข้าใจว่านับจาก A2 ไปถึง I2

ถ้าอธิบายให้พอสังเขปจะดีมากเลยครับ

Code: Select all

rIf rt = rs Then rt.Offset(0, 4) = rs.Offset(0, 1)

ใช้ได้ตามต้องการเลยครับ ขอบคุณครับ

[DhitiBank]

ผมจำแบบนี้ครับ

Offset(จำนวนแถวที่เลื่อน,จำนวนคอลัมน์ที่เลื่อน)

rs.offset(0,1)
หมายความว่า เซลล์ที่ขยับจากเรนจ์ rs ไปทางขวาเป็นระยะ 1 คอลัมน์ครับ

หากตัวเลขเป็นบวก ทิศทางจะเลื่อนลง หรือไปทางขวา

หากตัวเลขเป็นลบ ทิศทางจะเลื่อนขึ้น หรือไปทางซ้าย

หากเป็น 0 ก็จะไม่มีการเลื่อนในแกนนั้นๆ ครับ

[Totem]

ผมจำแบบนี้ครับ

Offset(จำนวนแถวที่เลื่อน,จำนวนคอลัมน์ที่เลื่อน)

rs.offset(0,1)
หมายความว่า เซลล์ที่ขยับจากเรนจ์ rs ไปทางขวาเป็นระยะ 1 คอลัมน์ครับ

หากตัวเลขเป็นบวก ทิศทางจะเลื่อนลง หรือไปทางขวา

หากตัวเลขเป็นลบ ทิศทางจะเลื่อนขึ้น หรือไปทางซ้าย

หากเป็น 0 ก็จะไม่มีการเลื่อนในแกนนั้นๆ ครับ

จากตัวอย่าง จะเริ่มต้นที่ In rSource คือ H2 เป็น offset (0,0) จากนั้นเลื่อนไปทางขวา นับจากช่อง H2 ไปที่ I2 คือ rs.offset (0,1) ผมเข้าใจอย่างนี้ถูกต้องใช่ไหมครับ

ผมไม่ค่อยเข้าใจว่าจะเริ่มต้นนับตั้งแต่ตรงไหนเป็น offset (0,0)

[DhitiBank]

อธิบายจากโค้ดตรงช่วง Loop นะครับ

For Each rs In rSource
--rSource คือค่าในคอลัมน์ H เริ่มตั้งแต่ H2:H7 เราจะให้ตัวแปร rs แทนเรนจ์แต่ละค่าใน rSource นี้
--เริ่มแรก rs คือเซลล์ H2 ครับ

For Each rt In rTarget
--rTarget คือช่วงในคอลัมน์ A โดยให้ตัวแปร rt แทนเรนจ์แต่ละค่าใน rTarget
--rt ค่าแรกคือเรนจ์ A2 ซึ่งมีค่าเท่ากับ aa

If rt = rs Then rt.Offset(0, 4) = rs.Offset(0, 1)
--เงื่อนไขคือ หาก rt=rs ก็ให้ค่าในเซลล์ E2 (rt.offset(0,4) คือเซลล์ที่อยู่ถัดจาก rt ไปทางขวา 4 คอลัมน์) มีค่าเท่ากับเซลล์ I2 (rs.offset(0,1) คือเซลล์ที่อยู่ถัดจาก rs ไปทางขวา 1 คอลัมน์ครับ)
--แต่หากไม่เท่ากันก็จะข้าม Then ไปเลย แล้ว rt ก็จะวิ่งต่อไปยัง A3, A4, ... ไปเรื่อยๆ จนครบช่วง rTarget
--พอครบ loop ของ rt แล้วก็จะเริ่มวน loop ของ rs ตัวถัดไปครับ วนไปเรื่อยๆ จนครบทุกเรนจ์ใน rSource

งงไหมครับ ผมอธิบาย vba ไม่ค่อยเก่งเพราะเรียนแบบจำจากที่อื่นๆ มา ยังไม่ค่อยรู้ว่าจริงๆ แล้วแต่ละส่วนต้องเรียกว่าอะไรครับ ลองรันโค้ดทีละขั้นตอนโดยการกด F8 แล้วดูทีละขั้นครับว่าโค้ดทำงานอย่างไรตรงไหนบ้าง

[Totem]

ขอบคุณครับ

ถ้าหากมีเงื่อนไขเพิ่มเติม เช่น

ต้องการให้หารายการในช่อง H2:H7 และ I2:I7
เมื่อข้อมูลตรงกับในช่อง A2:A20 และ C2:C20
ให้คัดลอกรายการในช่อง J2:J7
ไปวางไว้ในช่อง E2:E20
หากรายการในช่อง H2:H7 และ I2:I7 ไม่ตรงกันกับ ในช่อง A2:A20 และ C2:C20
ไม่ต้องคัดลอกรายการในช่อง J2:J7
พอปรับ code ได้ไหมครับ

ขอบคุณครับ

SourceAndCopy_เพื่มเติม.xlsm

(16.96 KiB) Downloaded 25 times

[DhitiBank]

ปรับได้ครับ แต่คงต้องขอให้ลองปรับมาเองก่อนครับ
คำใบ้:

ตรงแถวๆ IF จะมี AND

[niwat2811]

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

Code: Select all

Sub Match_Data()
Dim lr As Long, i As Long
Dim x As Range
Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
For i = 2 To lr
    Set x = Range("H:H").Find(Cells(i, "A").Value)
    If Not x Is Nothing Then
        Range("C" & i).Value = Range("I" & x.Row).Value
        Range("E" & i).Value = Range("J" & x.Row).Value
    End If
Next i
Range("A1").Select
Application.ScreenUpdating = True
End Sub

[snasui]

คุณ niwat12811 ควรรอให้คุณ Totem ปรับมาเองก่อน แล้วค่อยช่วยปรับแก้ให้ในภายหลัง คุณ Totem จะได้มีประสบการณ์ในการทำงานกับ VBA ครับ

[Totem]

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

Code: Select all

Sub Match_Data()
Dim lr As Long, i As Long
Dim x As Range
Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
For i = 2 To lr
    Set x = Range("H:H").Find(Cells(i, "A").Value)
    If Not x Is Nothing Then
        Range("C" & i).Value = Range("I" & x.Row).Value
        Range("E" & i).Value = Range("J" & x.Row).Value
    End If
Next i
Range("A1").Select
Application.ScreenUpdating = True
End Sub

ขอบคุณครับ

ยังไม่ได้ตามที่ต้องการครับ เพราะว่า ข้อมูลช่อง C2 และ C10 ไม่ตรงกับ I2 และ I3 เมื่อไม่ตรงกัน

ฉะนั้น ช่อง E4 และ E10 ยังคงเป็นข้อมูลเดิม ไม่ต้องคัดลอก J2 และ J3 ไป ครับ

[snasui]

ลองปรับมาเองก่อนครับ ติดแล้วค่อยถามกันต่อ

[Totem]

คุณ niwat12811 ควรรอให้คุณ Totem ปรับมาเองก่อน แล้วค่อยช่วยปรับแก้ให้ในภายหลัง คุณ Totem จะได้มีประสบการณ์ในการทำงานกับ VBA ครับ

ขอบคุณครับ คุณ niwat12811 เดี๋ยวจะลองปรับดูครับ

[bank9597]

คุณ niwat12811 ควรรอให้คุณ Totem ปรับมาเองก่อน แล้วค่อยช่วยปรับแก้ให้ในภายหลัง คุณ Totem จะได้มีประสบการณ์ในการทำงานกับ VBA ครับ

ขอบคุณครับ คุณ niwat12811 เดี๋ยวจะลองปรับดูครับ

ได้ลองปรับโค๊ดที่ผมได้ตอบหรือยังครับ

Code: Select all

Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("h" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    For Each rt In rTarget
        For Each rs In rSource
            If rt = rs Then
                rt.Offset(0, 4) = rs.Offset(0, 1)
            End If
        Next rs
    Next rt
    
    Set rSource = Nothing
    Set rTarget = Nothing

End Sub

อ่านหลักการใช้ Offset ตามที่คุณ DhitiBank (ค่อนข้างเข้าใจง่าย)
และใช้ And เพิ่มเงื่อนไขก็จะสามารถแก้ปัญหาได้แล้วครับ

[Totem]

คุณ niwat12811 ควรรอให้คุณ Totem ปรับมาเองก่อน แล้วค่อยช่วยปรับแก้ให้ในภายหลัง คุณ Totem จะได้มีประสบการณ์ในการทำงานกับ VBA ครับ

ขอบคุณครับ คุณ niwat12811 เดี๋ยวจะลองปรับดูครับ

ได้ลองปรับโค๊ดที่ผมได้ตอบหรือยังครับ

Code: Select all

Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("h" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    For Each rt In rTarget
        For Each rs In rSource
            If rt = rs Then
                rt.Offset(0, 4) = rs.Offset(0, 1)
            End If
        Next rs
    Next rt
    
    Set rSource = Nothing
    Set rTarget = Nothing

End Sub

อ่านหลักการใช้ Offset ตามที่คุณ DhitiBank (ค่อนข้างเข้าใจง่าย)
และใช้ And เพิ่มเงื่อนไขก็จะสามารถแก้ปัญหาได้แล้วครับ

ตาม code ที่ให้มานั้น ได้ตามต้องการตามปัญหาแรกครับ ขอบคุณครับ

ลองปรับใหม่ตามปัญหาต่อมา ได้ดังนี้ครับ

Code: Select all

Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("h" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    For Each rt In rTarget
        For Each rs In rSource
            If rt = rs And rt.Cells(1, "C").Value = rt.Cells(1, "I").Value Then
                rt.Offset(0, 4) = rs.Offset(0, 1)
            End If
        Next rs
    Next rt
    
    Set rSource = Nothing
    Set rTarget = Nothing

End Sub

ยังติดปัญหาที่ เมื่อวนไปถึงตั้งแต่ ช่อง E5 ลงมายังไม่นำข้อมูลช่อง I4 มาวาง ครับ

[bank9597]

ลองโค๊ดนี้ดูครับ

Code: Select all

Option Explicit
Public Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("h" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    For Each rt In rTarget
        For Each rs In rSource
            If rt = rs And rt.Offset(0, 2) = rs.Offset(0, 1) Then
                rt.Offset(0, 4) = rs.Offset(0, 2)
            End If
        Next rs
    Next rt
    
    Set rSource = Nothing
    Set rTarget = Nothing

End Sub

[Totem]

ลองโค๊ดนี้ดูครับ

Code: Select all

Option Explicit
Public Sub SourceAndCopy()
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
    With Sheets("data")
        Set rSource = .Range("H2", .Range("h" & Rows.Count).End(xlUp))
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    For Each rt In rTarget
        For Each rs In rSource
            If rt = rs And rt.Offset(0, 2) = rs.Offset(0, 1) Then
                rt.Offset(0, 4) = rs.Offset(0, 2)
            End If
        Next rs
    Next rt
    
    Set rSource = Nothing
    Set rTarget = Nothing

End Sub

ขอบคุณครับ คุณbank9597

ได้ตามที่ต้องการ พอเข้าใจวิธีการทำงานบ้างแล้วครับ

ขอบคุณ อาจารย์และเพื่อนสมาชิกที่ช่วยแก้ไขให้ครับ