vba - 基于两个单元格的唯一列表
问题描述
我正在使用以下代码提取唯一客户列表,我想根据 F 列和 K 列两列的组合提取列表。有没有办法更新此代码,那会有效吗?
Sub FilterUniqueCustomer()
Application.ScreenUpdating = False
'Advance Filter
Range("F1").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("F1:F100").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"S1"), Unique:=True
ActiveWindow.SmallScroll Down:=-6
'Copy Values
Range("T2:T100").Select
Selection.copy
Range("U2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Clear Formatting
Range("N4").Select
Selection.copy
Columns("S:S").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False 'Clears clipboard
Call DeleteZerosCustomer
Application.ScreenUpdating = True
End Sub
解决方案
像这样使用字典来获得独特的组合和数组比在工作表中工作得更快。
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim arr(), i As Long, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet3") '<==Change as required
arr = .Range("F1:K6").Value
For i = LBound(arr, 1) To UBound(arr, 1)
dict(arr(i, 1) & "," & arr(i, 6)) = 1
Next
End With
Dim key As Variant, rowCounter As Long
For Each key In dict.keys
rowCounter = rowCounter + 1
Worksheets("Sheet2").Cells(rowCounter + 1, 1).Resize(1, 2) = Split(key, ",") '<== Change output sheet as required
Next
Application.ScreenUpdating = True
End Sub
推荐阅读
- javascript - “AngularFirestoreCollection”类型上不存在属性“onSnapshot”
' - excel - 如何防止多个Excel工作表中的重复值
- python - 是否可以为每个模型自动创建视图集和序列化器?
- snmp - PySNMP 陷阱 OID 字符串值正在转换为十六进制
- python - 来自 scipy.fft 的幅度
- dynamics-crm - 当对象类型未知时,我可以使用 FetchXML 通过 guid 检索实体吗?
- angular - 防止 CSS 样式在 Angular 应用程序之外应用
- react-hooks - 使用去抖动的 onChange 处理程序设置输入值
- javascript - 如何在 OpenLayers 中的两个遥远多边形之间创建飞行动画
- audio - 为什么我的音高对象听起来与 PRAAT 中的原始音频文件不同?