VBA拼接一维数组元素报错？Outlook邮件ID去重拼接问题排查

错误根源 #

你遇到的运行时错误5，核心原因是**WorksheetFunction.Unique和Sort返回的是二维数组**，但Join函数只能处理一维数组。

原代码里：

• arrMatchID是手动构建的一维数组，所以直接用Join(arrMatchID, ", ")能正常运行，但没做去重处理。
• 当你用WorksheetFunction.Transpose(arrMatchID)转换数组时，返回的是单列二维数组（索引方式为RemArrDups(1,1)、RemArrDups(2,1)），后续Unique和Sort处理后依然是二维结构，Join无法识别这种格式，直接调用就会报错。

解决方法 #

给你两种可行的修正思路：

思路一：将二维数组转成一维后再拼接

在Join前，把处理后的二维数组转成一维结构：

Sub Scrap_IDs()
    Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
    Dim olFolder As MAPIFolder: Set olFolder = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("Folder_name")

    Dim olMail As Variant: For Each olMail In olFolder.Items
        Dim mBody As String: mBody = olMail.Body
    
        With olMail
        ' 正则提取所有ID
             With New RegExp
                    .Global = True
                    .Pattern = "ID \d+" ' 修正正则，确保匹配"ID 数字"的格式
            
            Dim MatchID As Object, i As Long, arrMatchID()
            i = 0
            For Each MatchID In .Execute(mBody)
                    ReDim Preserve arrMatchID(i)
                    arrMatchID(i) = MatchID.Value
                    i = i + 1
                Next
            End With
            
        ' 去重并排序
            Dim RemArrDups As Variant
            RemArrDups = WorksheetFunction.Sort(WorksheetFunction.Unique(WorksheetFunction.Transpose(arrMatchID)))
            
        ' 二维转一维数组
            Dim tempArr() As String, j As Long
            ReDim tempArr(1 To UBound(RemArrDups, 1))
            For j = 1 To UBound(RemArrDups, 1)
                tempArr(j) = RemArrDups(j, 1)
            Next j
            
        ' 拼接成字符串
            Dim IDs As String: IDs = Join(tempArr, ", ")
            ' 可添加输出逻辑，比如MsgBox IDs
        End With
    Next
End Sub

思路二：用字典去重（更稳定，不依赖Excel函数）

如果你的Outlook环境调用Excel函数有兼容性问题，或者想避免数组维度麻烦，可以用字典自动去重，再排序拼接：

Sub Scrap_IDs()
    Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
    Dim olFolder As MAPIFolder: Set olFolder = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("Folder_name")
    
    ' 字典自动去重，键存储唯一ID
    Dim idDict As Object: Set idDict = CreateObject("Scripting.Dictionary")
    
    Dim olMail As Variant
    For Each olMail In olFolder.Items
        Dim mBody As String: mBody = olMail.Body
        
        With New RegExp
            .Global = True
            .Pattern = "ID \d+"
            Dim MatchID As Object
            For Each MatchID In .Execute(mBody)
                If Not idDict.Exists(MatchID.Value) Then
                    idDict.Add MatchID.Value, Empty
                End If
            Next
        End With
    Next
    
    ' 字典键转数组并排序
    Dim sortedIDs As Variant
    sortedIDs = WorksheetFunction.Sort(idDict.Keys)
    
    ' 拼接最终字符串
    Dim finalIDs As String: finalIDs = Join(sortedIDs, ", ")
    MsgBox finalIDs ' 输出结果
End Sub

注：正则表达式Pattern改为"ID \d+"，是为了精准匹配"ID+空格+数字"的格式，避免匹配到多余空格或无空格的异常情况。

额外说明 #

如果你的Excel版本在2019之前，WorksheetFunction.Unique和Sort不存在，建议用字典去重+手动排序的方案，兼容性更好。另外，原代码是逐封邮件单独处理ID，如果你需要提取所有邮件的合并唯一ID，思路二的全局字典方案更符合需求。

内容的提问来源于stack exchange，提问作者Rayearth