VBA：使用过滤的行和 SpecialCells(xlCellTypeVisible) 与将数据复制到新工作表中

Question

我有一个包含 250,000 行和 10 列的 Excel 工作簿，我想将数据拆分到不同的工作簿中。我的想法是过滤列表，以便 Excel/VBA 不必每次我的代码说要在数据中查找某些内容时都遍历所有 250,000 行。

但是，我遇到了Sort 的一个特定问题，并且还有一个关于隐藏行和SpecialCells(xlCellTypeVisible) 的一般性问题。首先，这是代码：

Option Explicit

Sub Filtering()
   Dim wsData As Worksheet
   Dim cell As Variant
   Dim lRowData As Long, lColData As Long

'filter
   Set wsData = ThisWorkbook.Sheets(1)
   lRowData = wsData.Cells(Rows.Count, 1).End(xlUp).Row
   wsData.Range("A:A").AutoFilter Field:=1, Criteria1:="Name1"
   For Each cell In wsData.Range(wsData.Cells(2, 1), wsData.Cells(100, 1)).SpecialCells(xlCellTypeVisible)
       Debug.Print cell.Value 
   Next cell

'sort
   lColData = wsData.Cells(1, Columns.Count).End(xlToLeft).Column   
   wsData.Range(wsData.Cells(1, 1), wsData.Cells(lRowData, lColData)).SpecialCells(xlCellTypeVisible).Sort Key1:=wsData.Range("B1:B100"),   Order1:=xlDescending, Header:=xlYes ' returns error because of SpecialCells

End Sub

1. “运行时错误 '1004'：这不能在多范围选择上完成。选择单个范围并重试。”这发生在最后一行，在 wsData.Range(wsData.Cells(1, 1), wsData.Cells(lRowData, lColData)).SpecialCells(xlCellTypeVisible).Sort Key1:=wsData.Range("B1:B100"), Order1:=xlDescending, Header:=xlYes。只有当我使用SpecialCells(xlCellTypeVisible) 时才会发生这种情况，所以wsData.Range(wsData.Cells(1, 1), wsData.Cells(lRowData, lColData)).Sort Key1:=wsData.Range("B1:B100"), Order1:=xlDescending, Header:=xlYes 有效。

我在使用SpecialCells(xlCellTypeVisible) 时的想法是，只有这样 VBA 才会跳过过滤的单元格。不过，我已经尝试过了，在我看来，.Sort 无论如何都会跳过它们，不管有没有SpecialCells(xlCellTypeVisible) - 有人可以证实这一点吗？

1. 这导致了我更普遍的问题：我不太清楚的一件事是 Excel/VBA 什么时候跳过过滤的行，什么时候不跳过。要遍历可见单元格，我需要使用SpecialCells(xlCellTypeVisible)。 .Sort 我（也许）不会？对于我将在这些过滤列表上执行的任何操作，这个问题总是会弹出。

这让我想知道：我应该使用隐藏部分数据的原始工作表，还是应该临时创建一个新工作表，只复制我需要的数据（= 不包括我用过滤器隐藏的行）然后使用它？这张新表会以任何方式使其更快或更容易吗？在你的经历中什么更好？

Answer 1

1. 当您尝试复制不相邻的单元格或范围选择时会出现第一个错误，例如同一列（A1、A3、A5）中的多个不相邻行。这是因为 Excel 将范围“滑动”在一起并将它们粘贴为单个矩形。您可见的特殊单元格不相邻，因此不能复制为单个范围。

2. 似乎 excel 正在循环遍历您范围内的所有单元格，而不仅仅是可见的单元格。您的 debug.print 返回的行数不仅仅是可见的行数。

我会采用不同的方法通过使用数组来解决您的问题，与工作表相比，VBA 能够以极快的速度循环。

使用这种方法，我能够在 4.55 秒内从 190k 的样本大小中根据第一列的值复制 9k 行和 10 列：

编辑：我对数组进行了一些处理，使时间缩短到 0.45 秒，使用以下命令从初始 190k 的第一列复制 9k 行：

Option Explicit

Sub update_column()

Dim lr1 As Long, lr2 As Long, i As Long, j As Long, count As Long, oc_count As Long
Dim arr As Variant, out_arr As Variant
Dim start_time As Double, seconds_elapsed As Double
Dim find_string As String

start_time = Timer

' change accordingly
find_string = "looking_for"

With Sheets("Sheet1")

    ' your target column in which you're trying to find your string
    lr1 = .Cells(Rows.count, "A").End(xlUp).Row
    lr2 = 1

    ' all of your data - change accordingly
    arr = .Range("A1:J" & lr1)

    ' get number of features matching criteria to determine array size
    oc_count = 0
    For i = 1 To UBound(arr, 1)
        If arr(i, 1) = find_string Then
            oc_count = oc_count + 1
        End If
    Next

    ' redim array
    ReDim out_arr(oc_count, 9)

    ' write all occurrences to new array
    count = 0
    For i = 1 To UBound(arr, 1)
        If arr(i, 1) = find_string Then
            For j = 1 To 10:
                out_arr(count, j - 1) = arr(i, j)
            Next j
            count = count + 1
        End If
    Next

    ' write array to your target sheet, change sheet name and range accordingly
    Sheets("Sheet2").Range("A1:J" & (oc_count + 1)) = out_arr

End With

seconds_elapsed = Round(Timer - start_time, 2)
Debug.Print (seconds_elapsed)

End Sub

它不是超级干净，可能需要一些精炼，但如果速度很重要（它通常看起来很重要），这应该适合你。

Answer 2

根据 bm13563 评论，您正在复制不相邻的单元格。 此外，使用排序会改变您的基础数据，如果您需要确定未来最初的排序方式，这可能会产生影响。

使用过滤器可能会变得相当复杂，因此更简单（而且不是特别慢）的方法可能是使用您选择的列中的过滤值进行字符串搜索，然后循环遍历返回的实例，对每个结果执行操作。

下面来自 David Zemens 的（略微改编的）代码将是一个很好的起点（复制自 Find All Instances in Excel Column）

Sub foo()

Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

Set huntRange = Range("A:B")
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:="January", after:=LastCell, LookIn:=xlValues)

If Not FoundCell Is Nothing Then
    FirstFound = FoundCell.Address
    Do
        'Do your actions here, you can get the address of the found cell to return row etc.
        MsgBox (FoundCell.Value)
        Set FoundCell = myRange.FindNext(FoundCell)

    Loop While (FoundCell.Address <> FirstFound)
End If

Set rng = FoundCell  '<~~ Careful, as this is only the LAST instance of FoundCell.

End Sub