Excel VBA 查找重复项并发布到不同的工作表

Question

我一直遇到 VBA Excel 中的一些代码问题，正在寻求帮助！

我正在尝试对具有相应电话号码的姓名列表进行排序，检查同一电话号码下的多个姓名。然后将这些名称发布到单独的表格中。

到目前为止，我的代码是：

Sub main()
    Dim cName As New Collection
    For Each celli In Columns(3).Cells
    Sheets(2).Activate
        On Error GoTo raa
            If Not celli.Value = Empty Then
            cName.Add Item:=celli.Row, Key:="" & celli.Value
            End If
    Next celli
        On Error Resume Next
raa:
    Sheets(3).Activate
    Range("a1").Offset(celli.Row - 1, 0).Value = Range("a1").Offset(cName(celli.Value) - 1, 0).Value
    Resume Next
End Sub

当我尝试运行代码时，它会使 Excel 崩溃，并且没有给出任何错误代码。

我尝试解决的一些问题：

• 项目短清单

• 使用 cstr() 将电话号码转换为字符串

• 调整范围和偏移

我对这一切都很陌生，在本网站上其他帖子的帮助下，我才设法在代码上做到了这一点。不知道该去哪里，因为它只是崩溃并且没有给我任何错误可以查看。感谢您的任何想法谢谢！

更新：

Option Explicit
Dim output As Worksheet
Dim data As Worksheet
Dim hold As Object
Dim celli
Dim nextRow

Sub main()
    Set output = Worksheets("phoneFlags")
    Set data = Worksheets("filteredData")

    Set hold = CreateObject("Scripting.Dictionary")
        For Each celli In data.Columns(3).Cells
            On Error GoTo raa
            If Not IsEmpty(celli.Value) Then
                hold.Add Item:=celli.Row, Key:="" & celli.Value
            End If
        Next celli
        On Error Resume Next
raa:
    nextRow = output.Range("A" & Rows.Count).End(xlUp).Row + 1
    output.Range("A" & nextRow).Value = data.Range("A1").Offset(hold(celli.Value) - 1, 0).Value
    'data.Range("B1").Offset(celli.Row - 1, 0).Value = Range("B1").Offset(hold
    Resume Next
End Sub

更新2：

使用hold.Exists 和ElseIf 删除GoTo。还将其更改为将行复制并粘贴到下一张表。

Sub main()
    Set output = Worksheets("phoneFlags")
    Set data = Worksheets("filteredData")
    Set hold = CreateObject("Scripting.Dictionary")

    For Each celli In data.Columns(2).Cells
        If Not hold.Exists(CStr(celli.Value)) Then
            If Not IsEmpty(celli.Value) Then
                hold.Add Item:=celli.Row, Key:="" & celli.Value
            Else
            End If
        ElseIf hold.Exists(CStr(celli.Value)) Then
            data.Rows(celli.Row).Copy (Sheets("phoneFlags").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
            'output.Range("A" & nextRow).Value = data.Range("A1").Offset(hold(celli.Value) - 1, 0).Value
        End If
    Next celli
End Sub

Answer 1

在开发代码时，不要尝试（或害怕）错误，因为它们是帮助修复代码或逻辑的指针。因此，请勿使用On Error，除非在编码算法 (*) 中明确指出。在不必要的情况下使用On Error 只会隐藏错误，不会修复它们，并且在编码时总是最好首先避免错误（良好的逻辑）。

添加到词典时，首先检查该项目是否已存在。 Microsoft 文档指出，尝试添加已存在的元素会导致错误。 Dictionary 对象相对于 VBA 中的普通 Collection 对象的一个​​优势是 .exists(value) 方法，它返回一个 Boolean。

既然我已经了解了上下文，那么对您的问题的简短回答是，您可以先检查 (if Not hold.exists(CStr(celli.Value)) Then)，然后在它不存在时添加。

(*) 顺便说一句，我昨天解决了一个 Excel 宏问题，这让我花了一天的大部分时间来解决问题，但是错误的出现和调试代码的使用帮助我编写了一些稳定的代码，而不是一些错误但可以工作的代码（这是我首先要修复的）。但是，在某些情况下，使用错误处理可能是一种捷径，例如：

Function RangeExists(WS as Worksheet, NamedRange as String) As Boolean
Dim tResult as Boolean
Dim tRange as Range
    tResult = False ' The default for declaring a Boolean is False, but I like to be explicit
    On Error Goto SetResult ' the use of error means not using a loop through all the named ranges in the WS and can be quicker.
        Set tRange = WS.Range(NamedRange) ' will error out if the named range does not exist
        tResult = True
    On Error Goto 0 ' Always good to explicitly limit where error hiding occurs, but not necessary in this example
SetResult:
    RangeExists = tResult
End Function