ค้นหารายการแล้วเรียงข้อมูลติดกันไปอีก sheet ด้วย vba

[Totem]

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

ความต้องการที่คือ มีรายการอยู่ในคอลัมน์ A , B , C , E รายการในคอลัมน์ A , B เมื่อรายการไม่ตรงกับรายการในคอลัมน์ D , E ซึ่งหาออกมาได้แล้ว
แต่ต้องการ รายการที่แสดงออกมาที่อยู่ในคอลัมน์ G , H ต้องการให้เรียงติดกันและไปอยู่ใน Sheet2
ืที่ คอลัมน์ A , B ครับ ช่วยปรับ CODE นี้ด้วยครับ ขอบคุณครับ

Code: Select all

Sub Source()

    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
        Set ws1 = Workbooks("Sheet1").Sheets("Sheet1")
        Set ws2 = Workbooks("Sheet1").Sheets("Sheet2")
    
       With ws1
    
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        
        Set rSource = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
        
    End With
    
        
        
    For Each rt In rTarget
            For Each rs In rSource
            
          With ws2
        
                If rt = rs And rs.Offset(0, 1) <> rt.Offset(0, 1) Then
                rt.Offset(0, 6).Value = rt.Offset(0, 0).Value
                rt.Offset(0, 7).Value = rt.Offset(0, 1).Value

            End If
            
          End With
        
        Next rs
        
    Next rt
            
           Set rSource = Nothing
           
           Set rTarget = Nothing
           
       
End Sub

sheet1.xlsm

(17.47 KiB) Downloaded 20 times

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

'Other code
For Each rt In rTarget
    For Each rs In rSource
      With ws2
        If rt = rs And rs.Offset(0, 1) <> rt.Offset(0, 1) Then
            With ws2.Range("a" & .Rows.Count).End(xlUp)
                .Offset(1, 0).Value = rt.Value
                .Offset(1, 1).Value = rt.Offset(0, 1).Value
            End With
        End If
      End With
    Next rs
Next rt
'Other code

[Totem]

ได้ตามต้องการครับ ขอบคุณครับอาจารย์

[Totem]

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

ใน sheet1 คอลัมน์ A ตั้งแต่ A2 ลงไป และ sheet2 คอลัมน์ A ตั้งแต่ A12 ลงไป ทำการเปรียบเทียบกันโดย sheet2 คอลัมน์ A ตั้งแต่ A12 - A14 จะไม่ซ้ำกับ sheet1 คอลัมน์ A ตั้งแต่ A2 - A11 พิจารณาเฉพาะคอลัมน์ A แล้วนำรายการที่ไม่ซ้ำ sheet1 คอลัมน์ A แสดงออกมาใน sheet 2 คอลัมน์ C และ D
ผมได้นำ code มาไปปรับเพิ่มเติม แต่ยังไม่ได้ตามต้องการ
ขอบคุณครับ

Code: Select all

Sub Source()

    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
        Set ws1 = Workbooks("Sheet1").Sheets("Sheet1")
        Set ws2 = Workbooks("Sheet1").Sheets("Sheet2")
    
       With ws1
    
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        
         
    End With
        
        With ws2
        
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp))
        
    End With
           
        
    For Each rt In rTarget
    For Each rs In rSource
      With ws2
        If rt <> rs Then
            With ws2.Range("c" & .Rows.Count).End(xlUp)
                .Offset(1, 0).Value = rt.Value
                .Offset(1, 1).Value = rt.Offset(0, 1).Value
            End With
        End If
      End With
    Next rs
Next rt
            
           Set rSource = Nothing
           
           Set rTarget = Nothing
           
       
End Sub

sheet1.xlsm

(18.03 KiB) Downloaded 7 times

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
For Each rt In rTarget
    If Application.CountIf(rSource, rt) = 0 Then
        With ws2.Range("c" & ws2.Rows.Count).End(xlUp)
           .Offset(1, 0).Value = rt.Value
           .Offset(1, 1).Value = rt.Offset(0, 1).Value
        End With
    End If
Next rt
'Other code

[Totem]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
For Each rt In rTarget
    If Application.CountIf(rSource, rt) = 0 Then
        With ws2.Range("c" & ws2.Rows.Count).End(xlUp)
           .Offset(1, 0).Value = rt.Value
           .Offset(1, 1).Value = rt.Offset(0, 1).Value
        End With
    End If
Next rt
'Other code

ได้ตามต้องการครับ ขอบคุณครับอาจารย์

[Totem]

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

อยากให้ปรับ code ให้ครับ
อธิบายดังนี้ ใน sheet1 คอลัมน์ D รายการที่แตกต่างจาก คอลัมน์ A ในแถวใด ให้ไปวางแทนที่ในแถวนั้นครับ ผมลองปรับไป 2 แบบยังไม่ได้ครับ

Code: Select all

Sub Source()

    Dim raLL, r1aLL   As Range
    Dim r, r1 As Range
    Dim rt1, rs1 As Range
    

                With Sheets("Sheet1")
                Set raLL = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
                Set r1aLL = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
            End With
            
            For Each r1 In r1aLL
                
                For Each r In raLL
                
                With Sheets("Sheet1")
                
                    If r1 <> r Then

                    With Sheets("Sheet1").Range("b" & .Rows.Count).End(xlUp)
                            r.Offset(0, 0).Value = r1.Offset(0, 0).Value

                End With
            End If
             Exit For
          End With
        Next r
    Next r1
            
           Set r1aLL = Nothing
           
           Set raLL = Nothing
       
End Sub

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

Code: Select all

                    With Sheets("Sheet1").Range("b" & .Rows.Count).End(xlUp)
                            r.Offset(0, 0).Value = r1.Offset(0, 0).Value

พอ Exit for ไปวางที่ ช่อง A2 แล้วไม่เลื่อนลงมาตามตำแหน่งที่ต้องการ

Code: Select all

Sub Source1()

    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    
        Set ws1 = Workbooks("Sheet1").Sheets("Sheet1")
    
       With ws1
    
        Set rTarget = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        
        Set rSource = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
        
    End With
           
        
        For Each rt In rTarget
            If Application.CountIf(rSource, rt) = 0 Then
                With ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp))
                    .Offset(0, 0).Value = rt.Offset(0, 0).Value
                End With
            End If
        Next rt
            
           Set rSource = Nothing
           
           Set rTarget = Nothing
           
       
End Sub

ถ้า code นี้ ติดตรงนี้ครับ

Code: Select all

With ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp))

วางซ้ำกันทั้งหมด หากไม่ ใส่ ก็จะวางที่ตำแหน่งเดียวไม่เลื่อนลงมาให้ตรงตามที่ต้องการครับ

ขอบคุณครับ

sheet1.xlsm

(18.74 KiB) Downloaded 6 times

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Dim r As Range
With Worksheets("Sheet1")
    For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
        If r.Value <> r.Offset(0, 3).Value Then
            r.Value = r.Offset(0, 3).Value
        End If
    Next r
End With

[Totem]

ได้ตามต้องการครับ ขอบคุณครับ