Копировать / Вставить удалить дубликаты / пробелы: столбец массива

Question

Эта проблема связана с VBA.Включает в себя копирование и вставку данных (уникальные значения, форматирование и исключение пробелов).

Что у меня есть: 1 лист (БД) с разными заголовками, а затем у меня есть данные ниже (можнобыть числами или строками или пробелами).

Что я хочу: Имею на другом листе (место назначения) уникальные значения некоторых столбцов из источника данных, но без форматирования данных и без пробелов.

Моя идея:

1. Скопируйте определенные столбцы, которые я хочу на листе БД, и вставьте в лист назначения(также конкретные столбцы).Всегда следует от 1 столбца в начале координат до 1 столбца в месте назначения.Вставьте как значения.
2. Выберите столбцы на листе назначения и удалите дубликаты
3. Выберите столбцы на листе назначения и удалите пробелы (также сортировка по возрастанию будет работать, так как заготовки будут перемещены в конец)

Код:

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

Проблемы:

1. Удаление пробелов / пустого кода не работает (я пытался принять методологию сортировки по возрастанию), но все еще не мог понять, что не так.
2. Есть ли способ удалить дубликаты и сортировать в той же группе кода?вместо того, чтобы снова открывать «С» и «Завершить».

Большое спасибо за ваше время и за вашу помощь

Я включил весь код, потому что он может быть полезендля кого-то еще, кто пытается сделать подобное.

Хорошего дня

Answer 1

Было несколько проблем с вашим кодом:

1) Не используйте сортировку для удаления пустых ячеек из диапазона.В Excel есть собственная функция для этого.

2) Назовите свои массивы более удобными для чтения, чтобы не путать исходный лист с листом назначения.

3) При записи вдокумент, установите ScreenUpdating на False, чтобы код работал быстрее.

Это работает для меня:

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