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

“运行时错误'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)都会跳过它们-有人可以确认吗？

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

这让我感到奇怪：我应该使用隐藏了部分数据的原始工作表还是应该临时创建新工作表，仅复制所需的数据（=排除使用过滤器隐藏的行）然后使用它？这张新纸可以使它更快或更容易吗？您的经验中有什么更好的？

Answer 1

当您尝试复制不相邻的单元格或范围选择（例如同一列（A1，A3，A5）中的多个不相邻的行）时，会发生第一个错误。这是因为Excel将范围“滑动”在一起并将其粘贴为单个矩形。您可见的特殊单元格不相邻，因此不能复制为单个范围。
似乎excel遍历了您范围内的所有单元，而不仅仅是可见的单元。您的debug.print返回的行比可见行还要多。

我将通过使用数组来解决您的问题，与工作表相比，VBA可以非常快速地遍历数组。

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

编辑：我对数组进行了一些弄乱，使用以下命令将时间从最初的190k复制到0.45秒，从而从第一列开始复制9k行减少了0.45秒：

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

VBA：处理过滤的行和SpecialCells（xlCellTypeVisible）与将数据复制到新表中

2 个答案: