Copy/Paste remove duplicates/blanks: Array Column

Question

This issue is related with VBA. Involves copy and paste data (unique values, formatting and exclude blanks).

What I have: 1 sheet (DB) with different headers, and then I've the data below (can be numbers or strings or blanks).

What I want: Have in another sheet (Destination) with the unique values of some columns from the data source but without data formatting and without blanks.

My idea:

1. Copy the specific columns I want in DB sheet and paste into Destination sheet (specific columns as well). Always following the 1 column in origin to 1 column in the destination. Paste as values.
2. Select the columns in Destination sheet and remove duplicates
3. Select the columns in Destination sheet and remove blanks (also ascending sorting would work as the blanks would be moved to the end)

Code:

Sub Clean_Data()

Dim arr1, arr2, i As Integer
Dim LastNRow As Long
'Get the last used cell within the sheet (column in use A to L only) in order to capture the last row
With Sheets("DB")
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 'Select the Column Range below
        LastNRow = .Range("A:L").Find(What:="*", _
              After:=.Range("A1"), _
              Lookat:=xlPart, _
              LookIn:=xlFormulas, _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious, _
              MatchCase:=False).Row
    Else
        LastNRow = 1 'This won't ever happen
End If

    arr1 = Array("A", "B", "C", "D", "G", "H", "I", "J", "L") 'copy these columns in DB
    arr2 = Array("A", "D", "G", "J", "M", "P", "S", "V", "Y") 'paste into these columns in Destination

    For i = LBound(arr1) To UBound(arr1)
        With Sheets("DB")    
            .Range(.Cells(2, arr1(i)), .Cells(LastNRow, arr1(i))).Copy
            Sheets("Destination").Range(arr2(i) & 3).PasteSpecial Paste:=xlPasteValues
        End With
    Next

'remove the duplicates
    For i = LBound(arr2) To UBound(arr2)
        With Sheets("Destination")
            .Range(.Cells(3, arr2(i)), .Cells(LastNRow, arr1(i))).RemoveDuplicates Columns:=Array(1), Header:=xlNo
        End With
     Next

'remove the blank (I tried to use the sorting methodology as I couldn't figure out any code to remove the blanks/empty)
    For i = LBound(arr2) To UBound(arr2)
        With Sheets("Destination")
            .Range(.Cells(2, arr1(i)), .Cells(LastNRow, arr1(i))).Sort key1:=Array(1), order1:=xlAscending, Header:=xlNo
        End With
    Next
    Application.CutCopyMode = False

    End With

End Sub

Problems:

1. The remove blanks/empty code isn't working (I tried to adopt the ascending sorting methodology), but still couldn't figure out what is wrong.
2. Is there a way to remove duplicates and sort in the same code group? instead of opening again the "With" and "End With".

Thank you very much for your time and for your help

I included all the code because it may be useful for someone else who is trying to do similar thing.

Have a great day

Answer 1

There were a couple of issues with your code:

1) Don't use sorting for removing blank cells from a range. Excel has a native function for that.

2) Name your arrays more reader-friendly, so you don't confuse the source sheet with the destination sheet.

3) When writing to the document, set ScreenUpdating to False, so the code runs faster.

This works for me:

Sub removeDuplicatesAndBlankCells()

    Dim i As Long, LastNRow As Long
    Dim tmpRng As Range
    Dim arrDestSheet As Variant, arrSourceSheet As Variant

    Application.ScreenUpdating = False

    'Get the last used cell within the sheet (column in use A to L only) in order to capture the last row
    With Sheets("DB")
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 'Select the Column Range below
            LastNRow = .Range("A:L").Find(What:="*", _
                  After:=.Range("A1"), _
                  Lookat:=xlPart, _
                  LookIn:=xlFormulas, _
                  SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious, _
                  MatchCase:=False).Row
        Else
            LastNRow = 1 'This won't ever happen
    End If

    arrSourceSheet = Array("A", "B", "C", "D", "G", "H", "I", "J", "L") 'copy these columns in DB
    arrDestSheet = Array("A", "D", "G", "J", "M", "P", "S", "V", "Y") 'paste into these columns in Destination

    ' copy column content
    For i = LBound(arrSourceSheet) To UBound(arrSourceSheet)
        With Sheets("DB")
            .Range(.Cells(2, arrSourceSheet(i)), .Cells(LastNRow, arrSourceSheet(i))).Copy
            Sheets("Destination").Range(arrDestSheet(i) & 3).PasteSpecial Paste:=xlPasteValues
        End With
    Next

     ' remove blank cells
    For i = LBound(arrDestSheet) To UBound(arrDestSheet)
        With Sheets("Destination")
            Set tmpRng = .Range(.Cells(2, arrDestSheet(i)), .Cells(LastNRow, arrDestSheet(i)))
            tmpRng.SpecialCells(xlCellTypeBlanks).Delete
        End With
    Next

    ' remove duplicates
    For i = LBound(arrDestSheet) To UBound(arrDestSheet)
        With Sheets("Destination")
            .Range(.Cells(2, arrDestSheet(i)), .Cells(LastNRow, arrDestSheet(i))).removeDuplicates Columns:=Array(1), Header:=xlNo
        End With
    Next

    End With

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub