การจับคู่ Data ที่เหมือนกันระหว่าง 2 ชีท

[niwat2811]

รบกวนสอบถามท่านผู้รู้เกี่ยวกับการจับคู่ Data ที่เหมือนกันและให้แสดงผลออกมาตามที่ต้องการ
โดยมีข้อมูลอยู่ที่ Sheet Database ส่วนข้อมูลที่ต้องการนำมาเปรียบเทียบอยู่ที่ Sheet Data
เมื่อ Run Macro ชื่อ Compare_Data แล้วได้ผลลัพธ์ออกมาไม่ตรงตามต้องการ
โดยผลลัพธ์ที่ต้องการอยู่ที่ Sheet Result ครับ รบกวนท่านผู้รู้ช่วยชี้แนะการปรับ Code ให้ด้วยครับ
ขอบคุณครับ

[snasui]

เงื่อนไขการเปรียบเทียบคืออะไร อธิบายมาด้วยครับ

[niwat2811]

ข้อมูลที่นำมาเปรียบเทียบอยู่ที่ Sheet Data Columns A จากตัวอย่าง
A2 = 2.xxxxxxxxxx นำไปเทียบกับ Sheet Database Columns A จะพบค่าที่ซ้ำกัน 5 แถว
ก็ให้นำข้อมูลจาก Sheet Database Columns B ทั้ง 5 แถว มาวางที่ Sheet Data Columns B ครับ
A4 = 4.xxxxxxxxxx นำไปเทียบกับ Sheet Database Columns A จะพบค่าที่ซ้ำกัน 4 แถว
ก็ให้นำข้อมูลจาก Sheet Database Columns B ทั้ง 4 แถว มาวางที่ Sheet Data Columns B ครับ
A7 = 5.xxxxxxxxxx นำไปเทียบกับ Sheet Database Columns A จะพบค่าที่ซ้ำกัน 3 แถว
ก็ให้นำข้อมูลจาก Sheet Database Columns B ทั้ง 3 แถว มาวางที่ Sheet Data Columns B ครับ
คำตอบที่ต้องการอยู่ที่ Sheet Result ครับ ขอบคุณครับ

[snasui]

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

Code: Select all

Sub Compare_Data()
    Dim iCount As Integer, rCount As Integer
    Dim j As Integer, rAll As Range
    Dim r As Range, lMatch As Long
    With Sheets("Data")
        Set rAll = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        rCount = rAll.Count
        For j = rCount To 2 Step -1
            iCount = Application.CountIf(Sheets("Database").Columns(1), rAll(j))
            If iCount > 0 Then
                rAll(j).Resize(10).EntireRow.Insert
            End If
        Next j
        Set rAll = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeConstants)
        For Each r In rAll
            iCount = Application.CountIf(Sheets("Database").Columns(1), r)
            If iCount > 0 Then
                lMatch = Application.Match(r, Sheets("Database").Columns(1), 0)
                r.Offset(0, 1).Resize(iCount) = Sheets("Database") _
                    .Range("b" & lMatch).Resize(iCount).Value
            End If
        Next r
        .Range("b2", .Range("b" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

[niwat2811]

Code ที่ท่านอาจารย์ให้มาใช้ได้ตรงตามต้องการครับ ขอบคุณมากครับ