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

UPDATE2：

使用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不必要时使用On Error只会隐藏错误，不能修复它们，而在编码时始终最好一开始就避免错误（良好的逻辑）。

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

现在，有了我的上下文，对您的问题的简短回答是，您可以先检查（ if Not hold.exists(CStr(celli.Value)) Then ），然后添加（如果不存在）。

（*）作为附带说明，我昨天解决了一个Excel宏问题，这使我花了整整一天的时间来解决问题，但是错误的产生和调试代码的使用帮助我制作了一些稳定的代码，而不是一些有问题的bug工作代码（这是我首先修复的问题）。 但是，在某些情况下，使用错误处理可能是捷径，例如：

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