Excel Forum

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

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