Question

我有一个表，其中一列具有登录名，另一列具有电话号码。我需要复制每个登录名的所有电话号码并将其粘贴到另一张纸上。但是我只需要唯一的电话号码，因为一个登录名可能包含许多具有相同电话号码的记录。我尝试过的和失败的

For Each rCell In Sheets("PotentialFraud").Range("B1:B" & IndexValueLastRow("B:B"))
    .Range("A2").AutoFilter _
    field:=12, _
    Criteria1:=rCell.Value2
    LastRow = .Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
    .Range("P1:P" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
    Worksheets("PotentialFraud").Range(rCell.Offset(0, 2).Address).PasteSpecial Transpose:=True
Next rCell

此方法不能让我选择仅复制唯一值。我发现的另一个选择是使用“高级过滤器”

   .Range("P2:P" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Worksheets("PotentialFraud").Range("A:A"), _
        Unique:=True

但是，这会导致错误1004，提示此命令至少需要两行源数据... ，即使有2500行可见。 应用定义错误或对象定义错误，如果我将范围更改为

    .Range("P:P" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Worksheets("PotentialFraud").Range("A:A"), _
Unique:=True

（“ P2：P”）到（“ P：P”）

Answer 1

为什么您不能在Excel中使用板载删除重复项功能？ https://support.office.com/en-us/article/filter-for-unique-values-or-remove-duplicate-values-ccf664b0-81d6-449b-bbe1-8daaec1e83c2

或在VBA中：

ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=Array(1,2), Header:=xlYes

Answer 2

假设您想要唯一的登录电话对（而不仅仅是唯一的电话），则可以对工作表发出一条SQL语句，然后使用 CopyFromRecordset 将其粘贴到新的工作表中。

添加对 Microsoft ActiveX数据对象6.1库的引用（通过工具-> 参考... ）。可能有6.1以外的版本；选择最高的。

假设登录名位于A列中，电话号码位于P列中，并且源数据的工作表名称为RawData，则可以编写以下内容：

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & ActiveWorkbook.FullName & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No"""

Dim sql As String
sql = _
    "SELECT DISTINCT F1, F16 " & _
    "FROM [RawData$A:P]"

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Worksheets("PotentialFraud").Range("A1").CopyFromRecordset rs

注意：

如果要从数据中排除标题，请在连接字符串中设置HDR=Yes而不是HDR=No。在这种情况下，字段名称将不会自动定义（例如F1，F2等），而是第一行中定义的名称；应该相应地调整SQL（例如，用SELECT Login, Phone ...代替SELECT F1, F16 ...）
读取数据的代码（直到最后一行，实际上将数据粘贴到工作表中）仅需要ActiveX数据对象对象库，因此独立于任何给定的宿主或宿主对象模型。您只需要Excel文件的路径，而不是ActiveWorkbook.FullName。

或者，您可以使用字典。（添加对 Microsoft脚本运行时的引用。）

选择一些不会出现在登录名或电话中的字符，然后使用串联的登录名+字符+电话作为词典的键。（在下面的代码中，我正在使用~。）

Dim arr As Variant
arr = ActiveSheet.UsedRange.Value

Dim separator As String
separator = "~"

Dim dict As New Dictionary
Dim i As Integer
For i = 1 To UBound(arr)
    dict(arr(i, 1) & separator & arr(i, 2)) = 1 'dummy value
Next

然后，您可以遍历键，将字符拆分为字符，然后将部分写入适当的目标单元格中。

arr = dict.Keys
For i = 0 To UBound(arr)
    Dim key As String
    key = arr(i)

    With Worksheets("PotentialFraud")
        .Range(.Cells(i + 1, 1), .Cells(i + 1, 2)).Value = Split(key, separator)
    End With
Next

比遍历键更好的方法是，可以将Keys方法返回的数组写入适当大小的Range的Value属性中，然后在Range上调用TextToColumns。

'Fill dictionary, as above

arr = dict.Keys
Dim rng As Range
Set rng = Worksheets("PotentialFraud").Range("A1:A" & (UBound(arr) + 1))
rng.Value = dict.Keys
rng.TextToColumns Other:=True, otherchar:=separator

参考文献

ActiveX数据对象

Recordset object，Open method

Excel

脚本运行时

Dictionary object Keys method

VBA

UBound function，Split function

复制唯一的过滤后的列值VBA

2 个答案:

参考文献