หารายการ 2 column ด้วย Application.CountIfs

[Totem]

เรียนอาจารย์และเพื่อนสมาชิกทุกท่านครับ
มีรายการที่ยังแก้ไขไม่ได้จากการเขียน code โดยใช้ Application.CountIfs ในการหารายการที่ไม่ซ้ำกันใน 2 คอลัมน์
ซึ่งสามารถทำให้แสดงรายการออกมาได้แล้ว แต่ยังไม่ครบที่ต้องการ ขออธิบายดังนี้
จาก Sheets1 คอลัมน์ A , B ได้นำไปแสดงไว้ใน sheet2 คอลัมน์ C , B
แล้ว แต่ความต้องการให้เหมือนตามคอลัมน์ G , H รายการที่ไม่ครบคือที่ระบายสีไว้ ยกตัวอย่างคือ ในคอลัมน์ G ที่ช่อง G1 และ G2 เหมือนกันก็จริง แต่ในคอลัมน์ H ที่ ช่อง H1 และ H2 ไม่เหมือน แสดงว่ารายการในช่อง G2 และ H2 เป็นคนละรายการกันกับช่อง G1 และ H1 จึงนำมาแสดงรายการตามที่ระบายสีไว้ เป็นต้น
ช่วยปรับในส่วนนี้

Code: Select all

Application.CountIfs(rAll, r, rAll, r.Offset(0, 1)) = 0 And Application.CountIf(rTarget, r) = 0

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

Code: Select all

Sub ListDup()

    Dim rAll As Range
    Dim r As Range
    Dim rTarget As Range
    
    
    With Sheets("Sheet1")
        Set rAll = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
        
    With Sheets("Sheet2")
        Set rTarget = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
    End With
    
    With Sheets("Sheet1")
        For Each r In rAll
        If Application.CountIfs(rAll, r, rAll, r.Offset(0, 1)) = 0 And Application.CountIf(rTarget, r) = 0 Then
            
            With Sheets("Sheet2").Range("c" & .Rows.Count).End(xlUp)
               
                Range("c" & Rows.Count).End(xlUp).Offset(1, 0) = r
                Set rTarget = Range("c2", Range("c" & Rows.Count).End(xlUp))
                Range("d" & Rows.Count).End(xlUp).Offset(1, 0) = r.Offset(0, 1)
                
            End With

                End If
        Next r

    End With

End Sub

List.xlsm

[snasui]

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

Code: Select all

'Other code
For Each r In rAll
    If Application.CountIfs(Sheets("Sheet2").Range("c:c"), r.Value, _
        Sheets("Sheet2").Range("d:d"), r.Offset(0, 1).Value) = 0 Then
        With Sheets("Sheet2").Range("c" & .Rows.Count).End(xlUp)
            .Offset(1, 0).Resize(1, 2).Value = r.Resize(1, 2).Value
        End With
    End If
Next r
'Other code

[Totem]

เรียนอาจารย์และเพื่อนสมาชิกทุกท่าน
code ทีอาจารย์ได้ปรับมาให้ใช้ไปได้ ในกรณี sheets1 ข้อมูลคอลัมน์ A และ B ติดกัน นำไปปรับใช้ได้
แต่มีกรณีที่ผมนำไปปรับกับ ข้อมูล sheets1 ข้อมูลคอลัมน์ A , B และ c ซึ่งข้อมูลที่ต้องการ countifs
เป็น ข้อมูลคอลัมน์ A และ C ไม่ติดกันหรือเป็นคอลัมน์อื่น ๆ ที่ไม่ติดกัน ทำให้ไม่ได้รายการที่ต้องการครับ ช่วยปรับ code ตามตัวอย่างให้หน่อยครับ ขอบคุณครับ

Code: Select all

If Application.CountIfs(Sheets("Sheet2").Range("c:c"), r.Value, _
                            Sheets("Sheet2").Range("d:d"), r.Offset(0, 2).Value) = 0 Then

Code: Select all

Sub ListDup()

    Dim rAll As Range
    Dim r As Range
    Dim rTarget As Range
    
    
    With Sheets("Sheet1")
        Set rAll = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
        
    With Sheets("Sheet2")
        Set rTarget = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
    End With
    
    With Sheets("Sheet1")
                    For Each r In rAll
                        If Application.CountIfs(Sheets("Sheet2").Range("c:c"), r.Value, _
                            Sheets("Sheet2").Range("d:d"), r.Offset(0, 2).Value) = 0 Then
                            With Sheets("Sheet2").Range("c" & .Rows.Count).End(xlUp)
                                .Offset(1, 0).Resize(1, 3).Value = r.Resize(1, 3).Value
                            End With
                        End If
                    Next r

    End With

End Sub

List.xlsm

[snasui]

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

Code: Select all

'Other code
For Each r In rAll
    If Application.CountIfs(Sheets("Sheet2").Range("c:c"), r.Value, _
        Sheets("Sheet2").Range("d:d"), r.Offset(0, 2).Value) = 0 Then
        With Sheets("Sheet2").Range("c" & .Rows.Count).End(xlUp)
            .Offset(1, 0).Value = r.Value
            .Offset(1, 1).Value = r.Offset(0, 2).Value
        End With
    End If
Next r
'Other code

[Totem]

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

Code: Select all

'Other code
For Each r In rAll
    If Application.CountIfs(Sheets("Sheet2").Range("c:c"), r.Value, _
        Sheets("Sheet2").Range("d:d"), r.Offset(0, 2).Value) = 0 Then
        With Sheets("Sheet2").Range("c" & .Rows.Count).End(xlUp)
            .Offset(1, 0).Value = r.Value
            .Offset(1, 1).Value = r.Offset(0, 2).Value
        End With
    End If
Next r
'Other code

นำไปปรับใช้งานแล้ว ได้ตามต้องการครับ ขอบคุณครับอาจารย์

[Totem]

เรียนอาจารย์และเพื่อนสมาชิกทุกท่าน
ช่วยปรับ code ที่ได้นำไปใช้
โดยที่ sheet2 ในคอลัมน์ D ที่ระบายสีมีการเปลี่ยนแปลง และในคอลัมน์ B และ C นั้น ไปเปรียบเทียบกับ sheet1ในคอลัมน์ A , B , C เมื่อมีความแตกต่างกันใน sheet1 คอลัมน์ C ชื่อ list
ก็นำรายการ sheet2 ในคอลัมน์ D ชื่อ list ไปวางเปรียบเทียบกันใน sheet1
คอลัมน์ D ชื่อ ANS ตามที่ระบายสีไว้ครับ
ปัญหาคือนำไปวางแล้ว แต่ไม่ไปวางในตำแหน่งที่ต้องการครับ

ขอบคุณครับ

Code: Select all

Sub SH()

    Dim rAll As Range
    Dim r As Range
    Dim r1 As Range

    With Sheets("Sheet2")
        Set rAll = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
    End With
    
    With Sheets("Sheet1")
        Set r1 = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
    End With
    
    With Sheets("Sheet2")
    
        For Each r In rAll
    
            If Application.CountIfs(Sheets("Sheet1").Range("c:c"), r.Value, _
            Sheets("Sheet1").Range("a:a"), r.Offset(0, -2).Value, _
            Sheets("Sheet1").Range("b:b"), r.Offset(0, -1).Value) = 0 Then
        
        With Sheets("Sheet1")
               
            r1.Offset(1, 0).Value = r.Offset(0, 0).Value
                     
        End With
                End If
            Next r
        End With

List1.xlsm

[snasui]

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

Code: Select all

Dim rAll As Range, r As Range, rs1 As String, rs2 As String
Dim r1All As Range, r1 As Range, rt1 As String, rt2 As String

With Sheets("Sheet2")
    Set rAll = .Range("b2", .Range("b" & Rows.Count).End(xlUp))
End With

With Sheets("Sheet1")
    Set r1All = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With
For Each r1 In r1All
    rt1 = r1.Value & r1.Offset(0, 1).Value & r1.Offset(0, 2).Value
    rt2 = r1.Value & r1.Offset(0, 1).Value
    For Each r In rAll
        rs1 = r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value
        rs2 = r.Value & r.Offset(0, 1).Value
        If rt1 = rs1 Then
            Exit For
        ElseIf rs2 = rt2 Then
            r1.Offset(0, 3).Value = r.Offset(0, 2).Value
            Exit For
        End If
    Next r
Next r1

[Totem]

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