Question

此问题与VBA有关。涉及复制和粘贴数据（唯一值，格式和排除空格）。

我有什么： 1张（DB）有不同的标题，然后是我下面的数据（可以是数字或字符串或空格）。

我想要的是什么： 在另一个工作表（目标）中包含数据源中某些列的唯一值，但没有数据格式且没有空格。

我的想法：

将我想要的特定列在数据表中复制，并将粘贴复制到目标表中（特定列也是如此）。始终将原点中的1列跟随目标中的1列。粘贴为值。
选择目标工作表中的列和删除重复项
选择目标工作表中的列和删除空白（同时升序排序将在空白移动到最后时起作用）

代码：

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

问题：

删除空白/空代码不起作用（我尝试采用升序排序方法），但仍然无法弄清楚出了什么问题。
有没有办法删除重复项并在同一代码组中排序？而不是再打开＆＃34;用＆＃34;和＆＃34;结束＆＃34;。

非常感谢你的时间和帮助

我包含了所有代码，因为它可能对试图做类似事情的其他人有用。

度过美好的一天

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

复制/粘贴删除重复/空白：数组列

1 个答案: