Excel VBA类型不匹配(13)

Question

我在VBA中遇到类型不匹配错误,我不知道为什么.

此宏的目的是浏览Excel电子表格中的列并将所有电子邮件添加到数组中.每个电子邮件添加到第一个数组后,它也应该添加到第二个数组,但在@符号处分成两部分,以便将名称与域分开.像这样:person@gmail.com以person和gmail.com.

我得到的问题是,当它到达应该拆分电子邮件的点时,它会抛出类型不匹配错误.

特别是这部分:

strDomain = Split(strText, "@")

这是完整的代码:

Sub addContactListEmails()
    Dim strEmailList() As String    'Array of emails
    Dim blDimensioned As Boolean    'Is the array dimensioned?
    Dim strText As String           'To temporarily hold names
    Dim lngPosition As Long         'Counting

    Dim strDomainList() As String
    Dim strDomain As String
    Dim dlDimensioned As Boolean
    Dim strEmailDomain As String
    Dim i As Integer

    Dim countRows As Long
    'countRows = Columns("E:E").SpecialCells(xlVisible).Rows.Count
    countRows = Range("E:E").CurrentRegion.Rows.Count
    MsgBox "The number of rows is " & countRows

    'The array has not yet been dimensioned:
    blDimensioned = False

    Dim counter As Long
    Do While counter < countRows
        counter = counter + 1

        ' Set the string to the content of the cell
        strText = Cells(counter, 5).Value

        If strText <> "" Then

            'Has the array been dimensioned?
            If blDimensioned = True Then

                'Yes, so extend the array one element large than its current upper bound.
                'Without the "Preserve" keyword below, the previous elements in our array would be erased with the resizing
                ReDim Preserve strEmailList(0 To UBound(strEmailList) + 1) As String

            Else

                'No, so dimension it and flag it as dimensioned.
                ReDim strEmailList(0 To 0) As String
                blDimensioned = True

            End If

            'Add the email to the last element in the array.
            strEmailList(UBound(strEmailList)) = strText

            'Also add the email to the separation array
            strDomain = Split(strText, "@")
            If strDomain <> "" Then
                    If dlDimensioned = True Then
                        ReDim Preserve strDomainList(0 To UBound(strDomainList) + 1) As String
                    Else
                        ReDim strDomainList(0 To 0) As String
                        dlDimensioned = True
                    End If
                strDomainList(UBound(strDomainList)) = strDomain
            End If

        End If

    Loop


    'Display email addresses, TESTING ONLY!

    For lngPosition = LBound(strEmailList) To UBound(strEmailList)

        MsgBox strEmailList(lngPosition)

    Next lngPosition

    For i = LBound(strDomainList) To UBound(strDomainList)

        MsgBox strDomainList(strDomain)

    Next

    'Erase array
    'Erase strEmailList

End Sub

Answer 1

ReDim阵列是一个很大的麻烦.欢迎来到collections和Dictionarys 的世界. 始终可以访问集合对象.字典需要引用Microsoft Scripting Runtime(工具>引用>向下滚动以查找该文本并选中复选框>确定).它们可以为您动态更改大小,与阵列相比,您可以非常轻松地添加,删除项目,而词典尤其允许您以更合理的方式组织数据.

在下面的代码中我使用了字典,其中键是域(使用split函数获得).每value一个key与该域的电子邮件地址的集合.

设置断点End Sub并查看本地窗口中每个对象的内容.我想你会发现它们更有意义,而且一般来说更容易.

选项明确

Function AllEmails() As Dictionary

    Dim emailListCollection As Collection
    Set emailListCollection = New Collection 'you're going to like collections way better than arrays
    Dim DomainEmailDictionary As Dictionary
    Set DomainEmailDictionary = New Dictionary 'key value pairing. key is the domain. value is a collection of emails in that domain
    Dim emailParts() As String
    Dim countRows As Long
    Dim EmailAddress As String
    Dim strDomain As String

    'countRows = Columns("E:E").SpecialCells(xlVisible).Rows.Count
    Dim sht As Worksheet 'always declare your sheets!
    Set sht = Sheets("Sheet1")

    countRows = sht.Range("E2").End(xlDown).Row

    Dim counter As Long
    Do While counter < countRows
        counter = counter + 1

        EmailAddress = Trim(sht.Cells(counter, 5))

        If EmailAddress <> "" Then

            emailParts = Split(EmailAddress, "@")
            If UBound(emailParts) > 0 Then
                strDomain = emailParts(1)
            End If

            If Not DomainEmailDictionary.Exists(strDomain) Then
                'if you have not already encountered this domain
                DomainEmailDictionary.Add strDomain, New Collection
            End If

            'Add the email to the dictionary of emails organized by domain
            DomainEmailDictionary(strDomain).Add EmailAddress

            'Add the email to the collection of only addresses
            emailListCollection.Add EmailAddress
        End If
    Loop

    Set AllEmails = DomainEmailDictionary
End Function

并使用它

Sub RemoveUnwantedEmails()

    Dim allemailsDic As Dictionary, doNotCallSheet As Worksheet, emailsSheet As Worksheet
    Set doNotCallSheet = Sheets("DoNotCallList")
    Set emailsSheet = Sheets("Sheet1")
    Set allemailsDic = AllEmails

    Dim domain As Variant, EmailAddress As Variant
    Dim foundDoNotCallDomains As Range, emailAddressesToRemove   As Range

    For Each domain In allemailsDic.Keys
        Set foundDoNotCallDomains = doNotCallSheet.Range("A:A").Find(domain)
        If Not foundDoNotCallDomains Is Nothing Then
            Debug.Print "domain found"
            'do your removal
            For Each EmailAddress In allemailsDic(domain)
                Set emailAddressesToRemove = emailsSheet.Range("E:E").Find(EmailAddress)
                If Not emailAddressesToRemove Is Nothing Then
                    emailAddressesToRemove = ""
                 End If
            Next EmailAddress
        End If
    Next domain

End Sub