VBA数组定义优化求助：无需手动输入所有配送ID

你当前手动定义数组的方式效率低且易出错，下面是无需手动输入、自动从数据中提取对应公司配送ID数组的方案：

核心思路 #

利用VBA的**字典（Dictionary）**对象按公司名称分组，自动收集每行对应的所有配送ID，最终直接生成各公司的配送ID数组，无需手动录入。

完整代码示例 #

假设你的原始数据存放在Sheet1中，从A1单元格开始（第一列是公司名，后续列是配送ID），代码如下：

Sub GetCompanyDeliveryIDs()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim dict As Object
    Dim companyName As String
    Dim deliveryIDs As Variant
    Dim tempCollection As Collection
    
    ' 初始化字典（后期绑定，无需手动添加引用）
    Set dict = CreateObject("Scripting.Dictionary")
    ' 指定数据所在工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 获取数据的最后一行和最后一列
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 遍历每一行数据
    For i = 1 To lastRow
        ' 获取当前行的公司名称
        companyName = Trim(ws.Cells(i, "A").Value)
        ' 初始化临时集合用于存储当前行的配送ID
        Set tempCollection = New Collection
        
        ' 遍历当前行的所有配送ID列（从第2列开始）
        For j = 2 To lastCol
            If ws.Cells(i, j).Value <> "" Then
                tempCollection.Add ws.Cells(i, j).Value
            End If
        Next j
        
        ' 将当前行的配送ID添加到字典对应公司的集合中
        If dict.Exists(companyName) Then
            ' 如果公司已存在，合并现有集合和临时集合
            For Each deliveryIDs In tempCollection
                dict(companyName).Add deliveryIDs
            Next deliveryIDs
        Else
            ' 如果公司不存在，直接添加新集合
            Set dict(companyName) = tempCollection
        End If
    Next i
    
    ' 示例：将各公司配送ID复制到新工作表
    Dim newWs As Worksheet
    Dim key As Variant
    Dim arr() As String
    Dim k As Long, rowNum As Long
    
    ' 创建新工作表（如果不存在）
    On Error Resume Next
    Set newWs = ThisWorkbook.Sheets("公司配送ID")
    If Err.Number <> 0 Then
        Set newWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        newWs.Name = "公司配送ID"
    End If
    On Error GoTo 0
    
    ' 写入表头
    newWs.Cells(1, 1).Value = "公司名称"
    newWs.Cells(1, 2).Value = "配送ID"
    rowNum = 2
    
    ' 遍历字典，将数据写入新表
    For Each key In dict.Keys
        ' 将集合转换为数组
        ReDim arr(1 To dict(key).Count)
        For k = 1 To dict(key).Count
            arr(k) = dict(key)(k)
        Next k
        
        ' 写入公司名和配送ID数组
        newWs.Cells(rowNum, 1).Value = key
        newWs.Cells(rowNum, 2).Resize(1, UBound(arr)).Value = arr
        rowNum = rowNum + 1
    Next key
    
    ' 释放对象
    Set dict = Nothing
    Set ws = Nothing
    Set tempCollection = Nothing
    Set newWs = Nothing
End Sub

关键代码解释 #

• 字典对象：以公司名称作为Key，每个Key对应的Item是一个集合，自动存储该公司所有配送ID，实现分组管理。
• 数据遍历：逐行读取公司名，再逐列提取该行的配送ID，存入临时集合后合并到字典对应公司的集合中。
• 集合转数组：将字典中每个公司的集合转换为数组，方便后续的筛选、复制等操作。

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