VBA หาค่า unique ที่ไม่ซ้ำกันจาก inputหลายcolume อ้างอิง ไปเก็บไว้อีกout put colume

[lotto009]

เรียนอาจาร์ยครับ
สวัสดีใสช่วยที่ Covid-19กำลังหายไป ขอความช่วยเหลือเรื่องcode
-VBA หาค่า unique ที่ไม่ซ้ำกันจาก inputหลายcolume อ้างอิง ไปเก็บไว้อีกout put colume
ผมเขียนมาเบื้องต้นแล้วแต่ใช้ไม่ตรงตามต้องการครับ

Code: Select all

Private Sub CommandButton1_Click()
Dim MyDict As Object, MyCols As Variant, OutCol As String, LastRow As Long
Dim InputSh As Worksheet, OutputSh As Worksheet
Dim x As Variant, i As Long, MyData As Variant

    Set MyDict = CreateObject("Scripting.Dictionary")
    Set InputSh = Sheets("Sheet1")
    MyCols = Array("A", "B", "C", "D", "F")
    
    Set OutputSh = Sheets("Sheet1")
    OutCol = "H"
    
    For Each x In MyCols
        LastRow = InputSh.Cells(Rows.Count, x).End(xlUp).Row
        MyData = InputSh.Range(x & "1:" & x & LastRow).Value
        For i = 1 To UBound(MyData)
            If MyData(i, 1) <> "" Then MyDict(MyData(i, 1)) = 1
        Next i
    Next x
    OutputSh.Range(OutCol & "1").Resize(MyDict.Count, 1).Value = WorksheetFunction.Transpose(MyDict.keys)
    'OutputSh.Range(OutCol & ":" & OutCol).ClearContents
    
    Dim uniques As Collection
    Dim OutputSh22 As Worksheet
    Set uniques = Worksheets("Sheet1").Range("H2:H40")
    Set OutputSh22 = Worksheets("Sheet1").Range("H2:H40")
    Worksheets("Sheet1").Range("H2:H40").Sort
    
End Sub

ขอบพระคุณมากครับ
อาร์ต

[lotto009]

เรียนอาจาร์ยครับขออนุญาตเปลี่ยนขั้นตอนครับ
ขั้นตอนที่ 1
1. ผมมีข้อมูลดิบใน Input.Colume "F")
2. อ้างอิงค่าที่ไม่ซ้ำใน Colume "F" VS Colume "D") ใส่ค่าที่ไม่ซ้ำในคอลัมน์ "F" ไปยัง OUTPUT คอลัมน์ "H")
3. อ้างอิงค่าที่ไม่ซ้ำใน Colume "F" VS Colume "C") ใส่ค่าที่ไม่ซ้ำในคอลัมน์ "F" ไปยัง OUTPUT คอลัมน์ "H")
4. อ้างอิงค่าที่ไม่ซ้ำใน Colume "F" VS Colume "B") ใส่ค่าที่ไม่ซ้ำในคอลัมน์ "F" ไปยัง OUTPUT คอลัมน์ "H")

ขั้นตอนที่ 2
1. อ้างอิงค่าที่ไม่ซ้ำใน Colume "A" VS Colume "F") ใส่ค่าที่ไม่ซ้ำในคอลัมน์ "A" ไปยัง OUTPUT คอลัมน์ "H")

ขั้นตอนที่ 3
1. อ้างอิงค่าที่ไม่ซ้ำใน Colume "A" VS Colume "H") ใส่ค่าที่ไม่ซ้ำใน Colume "A" ไปยัง OUTPUT คอลัมน์ "H")
ขอบคุณครับ
อาร์ต

[lotto009]

V1-unique.xlsm

[snasui]

ทำให้ผ่านไปทีละขั้นตอนครับ

จากข้อความที่ยกมาด้านล่าง

อ้างอิงค่าที่ไม่ซ้ำใน Colume "F" VS Colume "D") ใส่ค่าที่ไม่ซ้ำในคอลัมน์ "F" ไปยัง OUTPUT คอลัมน์ "H")

กรุณาขยายความประโยคที่ผมระบายสีมาเพิ่มเติมว่าหมายถึงอะไร เขียนมาแล้วได้คำตอบหรือไม่ ติดขัดตรงไหน อย่างไรครับ

[lotto009]

เรียนอาจาร์ยครับ
ต้องขอโทษด้วยครับผมอธิบายไม่ชัดเจน ขั้นตอนแบบนี้ครับ ผมแนบไฟล์ใหมเลยนะครับ
ขั้นตอนที่ 1
1. ผมมีข้อมูลดิบใน Input.Colume "F")
2. ยืดค่าในColume "F" เป็นหลัก ทำUnique หาค่าไม่ซ้ำกับ Colume "D") นำค่าที่ไม่ซ้ำใน คอลัมน์ "F" ไปเก็บไว้ที่ OUTPUT คอลัมน์ "H")
3. ยืดค่าในColume "F" เป็นหลัก ทำUnique หาค่าไม่ซ้ำกับ Colume "C") นำค่าที่ไม่ซ้ำใน คอลัมน์ "F" ไปเก็บไว้ที่ OUTPUT คอลัมน์ "H")ต่อท้ายไปเรื่อยๆครับ
4. ยืดค่าในColume "F" เป็นหลัก ทำUnique หาค่าไม่ซ้ำกับ Colume "B") นำค่าที่ไม่ซ้ำใน คอลัมน์ "F" ไปเก็บไว้ที่ OUTPUT คอลัมน์ "H")ต่อท้ายไปเรื่อยๆครับ

ขั้นตอนที่ 2
1.ยืดค่าในColume "A" เป็นหลัก ทำUnique หาค่าไม่ซ้ำกับ Colume "F") นำค่าที่ไม่ซ้ำใน คอลัมน์ "A" ไปเก็บไว้ที่ OUTPUT คอลัมน์ "H")ต่อท้ายไปเรื่อยๆครับ
ขั้นตอนที่ 3
1.ยืดค่าในColume "A" เป็นหลัก ทำUnique หาค่าไม่ซ้ำกับ Colume "H") นำค่าที่ไม่ซ้ำใน คอลัมน์ "A" ไปเก็บไว้ที่ OUTPUT คอลัมน์ "H")
2.ทับของเก่าได้เลยครับ
ขอบคุณครับ
อาร์ต

[snasui]

ตัวอย่าง Code ขั้นตอนแรกครับ

Code: Select all

Sub Button3_Click()
    Dim arr(9999) As Variant, i As Long, j As Long
    Dim d As Object, rAll As Range, r As Range, k As Long
    Dim rAllSub As Range, arrU() As Variant
    Dim s As String, u As Variant
    Dim myCol As Variant
    myCol = Array("d", "c", "b")
    Set d = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")
        Set rAll = .Range("f2", .Range("f" & .Rows.Count).End(xlUp))
        For Each r In rAll
            s = CStr(r.Value)
            If Not d.Exists(s) Then
                d.Add Key:=s, Item:=s
            End If
        Next r
        arrU = d.keys
        For i = 0 To UBound(myCol)
            Set rAllSub = .Range(myCol(i) & 2, .Range(myCol(i) & .Rows.Count) _
                .End(xlUp))
            For j = 0 To UBound(arrU)
                If Application.CountIf(rAllSub, arrU(j)) = 0 Then
                    arr(k) = CLng(arrU(j))
                    k = k + 1
                End If
            Next j
        Next i
        If k > 0 Then
            If .Range("h2").Value <> "" Then
                .Range("h2", .Range("h" & .Rows.Count).End(xlUp)).ClearContents
            End If
            .Range("h2").Resize(k) = Application.Transpose(arr)
        End If
    End With
End Sub

ขั้นตอนที่เหลือลองทำมาเองก่อน ติดแล้วค่อยถามกันต่อครับ

[lotto009]

ขอบพระคุณมากครับอาจาร์ยของผม เป็นที่พึงพิงยามยากจริงจริง รักษาสุขภาพครับ ใส่แมสด้วยนะครับ
ผมจะไปทำต่อ