Plz help improving this macro

[jbesclapez]

Hello,

I have a macro that adds up data in 5 columns (Q to W) to a column(AB) and Erase the duplicates data.
However, the problem with this macro is that it does not work when there is nothing in one of the column...

Sub ThreeColDupes()
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("DB-Formules")
 'Si il y a une colonne vide dans le Array en dessous alors la macro ne fonctionne pas
    MyCols = Array("Q", "R", "S", "T", "U", "V", "W")
    
    
    Set OutputSh = Sheets("DB-Formules")
    OutCol = "AB"
    
    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)
    
End Sub

How can I solve that?
Thanks for your help

 

[JackDanIce]

Hi, your code appears to be finding unique values only in range Q1:W{last row} and placing them in a column starting in AB1, I'm not sure where it is adding any data.

See if this (untested) errors, it shouldn't matter if the column is empty or not. If it does error, please state what line it errors on and what the error message is:

Sub ThreeColDupe()

    Dim dic     As Object
    Dim LR      As Long
    Dim x       As Long
    Dim y       As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("DB-Formules")
        x = .Cells(.Rows.count, 17).End(xlUp).row
        arr = .Cells(1, 17).Resize(x, 7).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            For y = LBound(arr, 2) To UBound(arr, 2)
                If Len(arr(x, y)) > 0 Then dic(arr(x, y)) = 1
            Next y
        Next x
        
        .Cells(1, 27).Resize(dic.count).Value = Application.Transpose(dic.keys)
    End With
    
    Erase arr
    Set dic = Nothing
                                
End Sub

 

[jbesclapez]

Hi, your code appears to be finding unique values only in range Q1:W{last row} and placing them in a column starting in AB1, I'm not sure where it is adding any data.

See if this (untested) errors, it shouldn't matter if the column is empty or not. If it does error, please state what line it errors on and what the error message is:

Sub ThreeColDupe()

    Dim dic     As Object
    Dim LR      As Long
    Dim x       As Long
    Dim y       As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("DB-Formules")
        x = .Cells(.Rows.count, 17).End(xlUp).row
        arr = .Cells(1, 17).Resize(x, 7).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            For y = LBound(arr, 2) To UBound(arr, 2)
                If Len(arr(x, y)) > 0 Then dic(arr(x, y)) = 1
            Next y
        Next x
        
        .Cells(1, 27).Resize(dic.count).Value = Application.Transpose(dic.keys)
    End With
    
    Erase arr
    Set dic = Nothing
                                
End Sub

Hi Jack and thanks for taking time to answer me. I will have a close look at it!