如何按条件将两个1D数组合并为2D数组？VBA实现疑问

实现思路与代码 #

根据需求，通过遍历数组、判断触发条件的方式，可完成两个一维数组到目标二维数组的合并，代码如下：

Sub MergeTargetArrays()
    Dim arr1 As Variant, arr2 As Variant
    Dim arr3 As Variant
    Dim i As Long, stopPos As Long, rowNum As Long
    Dim currRow As Long
    
    ' 替换为你的实际输入数组
    arr1 = Array("A", "B", "C", "D", "E")
    arr2 = Array(1000, 2000, 6000, 7000, 8000)
    
    ' 定位第一个6000的位置作为停止节点
    stopPos = -1
    For i = LBound(arr2) To UBound(arr2)
        If arr2(i) = 6000 Then
            stopPos = i
            Exit For
        End If
    Next i
    
    ' 若未找到6000，直接终止程序
    If stopPos = -1 Then Exit Sub
    
    ' 统计目标数组需要的行数
    rowNum = 0
    i = LBound(arr2)
    Do While i <= stopPos
        rowNum = rowNum + 1
        If arr2(i) <> 6000 Then
            i = i + 1 ' 跳过已配对的下一个元素
        End If
        i = i + 1
    Loop
    
    ' 初始化二维数组（最大列数为3）
    ReDim arr3(1 To rowNum, 1 To 3)
    currRow = 1
    i = LBound(arr2)
    
    ' 执行合并逻辑
    Do While i <= stopPos
        If arr2(i) = 6000 Then
            ' 存入arr1(i)和arr2(i)
            arr3(currRow, 1) = arr1(i)
            arr3(currRow, 2) = arr2(i)
            currRow = currRow + 1
            Exit Do ' 遇到6000停止处理
        Else
            ' 存入arr1(i)、arr2(i)、arr2(i+1)
            arr3(currRow, 1) = arr1(i)
            arr3(currRow, 2) = arr2(i)
            arr3(currRow, 3) = arr2(i + 1)
            currRow = currRow + 1
            i = i + 1 ' 跳过已处理的i+1元素
        End If
        i = i + 1
    Loop
    
    ' 可选：将结果输出到工作表A1开始的区域
    Range("A1").Resize(UBound(arr3, 1), UBound(arr3, 2)).Value = arr3
End Sub

关键逻辑说明 #

1. 定位停止节点：先遍历arr2找到第一个值为6000的位置，后续处理只到该位置为止
2. 统计行数：预循环计算目标二维数组需要的行数，避免数组频繁重定义
3. 合并逻辑：
   • 当arr2当前元素为6000时，将arr1对应元素和6000存入二维数组一行，随即停止处理
   • 当元素不为6000时，将arr1对应元素、arr2当前元素及下一个元素存入二维数组一行，同时跳过已处理的下一个元素，避免重复操作

注意事项 #

• 确保arr1和arr2的长度一致，防止下标越界
• 若arr2中不存在6000，代码会直接退出，你可以根据需求补充这种场景的处理逻辑
• 若你的数组是从工作表读取的（默认下标从1开始），无需调整代码，LBound和UBound会自动适配

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