我有一个工作表，其中包含约8000行已被过滤的行。我试图从删除重复项的工作表列中获取值的集合。在这里通读文章有两种方法。如果新集合中不存在该值，则循环遍历该集合并复制到新集合。
或将列中的数据复制到临时电子表格，过滤并将数据复制到另一列，然后将其添加到集合中。
当处理大量数据时，复制过滤器具有最佳性能，但由于必须创建新的工作表而显得笨重。
我还没有看到它，但是有没有办法在内存中执行复制过滤器而不是创建工作表来执行此操作？
重申：
Sub GetColumnValues(Ws As Worksheet, Column As Long, CollValues As Collection)
Dim RowIndex As Long
For RowIndex = 1 To GetLastRow(Ws)
If CollValues.Count = 0 Then
CollValues.Add (Ws.Cells(RowIndex, Column).Value)
Else
If IsInCollection(CollValues, Ws.Cells(RowIndex, Column).Value) = False Then
CollValues.Add (Ws.Cells(RowIndex, Column).Value)
End If
End If
Next RowIndex
End Sub
筛选并复制：
Sub GetColumnValues(Ws As Worksheet, Column As Long, CollValues As Collection)
Dim rowLast As Long
Dim c As Range
Dim tmpWS As Worksheet
Dim tmpWsName As String
tmpWsName = "TempWS"
Call DeleteWs(TsWb, tmpWsName)
Set tmpWS = TsWb.Sheets.Add()
tmpWS.Name = tmpWsName
rowLast = GetLastRow(Ws)
Ws.Range(Ws.Cells(1, Column), Ws.Cells(rowLast, Column)).Copy
tmpWS.Range("A1").PasteSpecial
rowLast = GetLastRow(tmpWS)
tmpWS.Range(tmpWS.Cells(1, 1), tmpWS.Cells(rowLast, 1)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=tmpWS.Range("B1"), _
Unique:=True
rowLast = GetLastRow(tmpWS)
For Each c In tmpWS.Range(tmpWS.Cells(1, 2), tmpWS.Cells(rowLast, 2))
If Len(c.value) > 0 Then
CollValues.Add (c.value)
End If
Next c
Call DeleteWs(TsWb, tmpWsName)
End Sub
我不知道为什么它必须是一个集合，但是要使一个数组的所有值都快而没有（过滤列表的）双精度值，可以这样做：（非常接近第一个示例）
Function GetColVal(Ws As Worksheet, Column As Long) As Variant
Dim runner As Variant, outputVal() As Variant, i As Long
ReDim outputVal(Ws.Range(Ws.Cells(1, Column), Ws.Cells(GetLastRow(Ws), Column)).SpecialCells(xlCellTypeVisible).Count)
For Each runner In Ws.Range(Ws.Cells(1, Column), Ws.Cells(GetLastRow(Ws), Column)).SpecialCells(xlCellTypeVisible)
If i = 0 Then
outputVal(0) = runner.Value: i = 1
Else
If IsError(Application.Match(runner.Value, outputVal, 0)) Then outputVal(i) = runner.Value: i = i + 1
End If
Next
ReDim Preserve outputVal(i - 1)
GetColVal= outputVal
End Function
这Application.Match是VBA中最快的功能之一，而它却IsInCollection可能非常慢。...最好运行For Each ...循环以将所有内容添加到集合中，而不是检查集合...
Dim a As Variant
For Each a in GetColVal(Worksheets("SheetX"),7)
MyCollection.Add a
Next
应该比您的示例快得多...我仍然建议不要使用集合，特别是如果您只使用值的话...最好在GetColVal可能的情况下直接使用-array ...
variantVariable = GetColVal(Worksheets("SheetX"),7)然后对要执行的操作使用variant-variable也可以将其直接粘贴到工作表中的某处）
一个简单的输出到工作表将是这样的：
Dim a As Variant
a = GetColVal(Worksheets("Sheet1"),13) 'values from sheet1 column M
'pasting in one row (starting at A1 in Sheet2)
ThisWorkbook.Sheets("Sheet2").Range(Cells(1, 1), Cells(1, ubound(a) + 1)).value = a
'pasting in one column (starting at C5 in Sheet4)
ThisWorkbook.Sheets("Sheet4").Range(Cells(5, 3), Cells(ubound(a) + 5, 3)).value = Application.Transpose(a)
编辑
显示不同的内容：
Function GetColumnValues(ws As Worksheet, Column As Long) As Range
With ws
Dim srcRng As Range, outRng As Range, runRng1 As Range, runRng2 As Range, dBool As Boolean
Set srcRng = .Range(.Cells(1, Column), .Cells(GetLastRow(ws), Column)).SpecialCells(xlCellTypeVisible)
For Each runRng1 In a
If outRng Is Nothing Then Set outRng = runRng1
For Each runRng2 In outRng
If Intersect(runRng1, runRng2) Is Nothing Then
If runRng2.Value = runRng1.Value Then dBool = True: Exit For
End If
Next
If dBool Then dBool = False Else Set outRng = Union(outRng, runRng1)
Next
End With
Set GetColumnValues = outRng
End Function
使用此功能，您将获得可以选择或复制到其他位置的所有单元格的范围（包括格式化以及所有其他内容）。您仍然可以使用将所有元素添加到集合中For Each ...。我也不习惯Match避免出现“ Len> 255”错误
本文收集自互联网，转载请注明来源。
如有侵权，请联系[email protected] 删除。
我来说两句