这个如何才能让下标不出错？

ykcbf1100

代码没啥好改的，不如重写

cysczhumh

用DeekSeek修改了程序，主要采用了字典和数组相结合，这样表3中介质可以是任意顺序，就是程序有点长，感觉还有优化的地方。
Sub AppendAndTransformData()
    Application.ScreenUpdating = False
    t = Timer
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dict As Object
    Dim dataArr1 As Variant, dataArr2 As Variant, resultArr() As Variant
    Dim i As Long, j As Long, lastRow As Long, colCount As Long
    Dim dateStr As String, medium As String
    Dim planVal As Variant, actualVal As Variant
   
    ' 设置工作表对象
    Set ws1 = ThisWorkbook.Sheets("气瓶销售")
    Set ws2 = ThisWorkbook.Sheets("销售周报")
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' 获取Sheet3的日期
    dateStr = ws2.Range("B1").Value
   
    ' 读取Sheet3数据到数组
    lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    dataArr2 = ws2.Range("A2:C" & lastRow).Value
   
    ' 创建字典存储Sheet3的数据
    For i = 1 To UBound(dataArr2, 1)
        medium = dataArr2(i, 1)
        
        ' 安全处理数值
        planVal = IIf(IsNumeric(dataArr2(i, 2)), dataArr2(i, 2), 0)
        actualVal = IIf(IsNumeric(dataArr2(i, 3)), dataArr2(i, 3), 0)
        
        ' 存储介质对应的计划和实际值
        dict(medium) = Array(planVal, actualVal)
    Next i
   
    ' 读取Sheet1的数据
    lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    colCount = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    dataArr1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(lastRow, colCount)).Value
   
    ' 确定结果数组的大小
    Dim newRowCount As Long
    newRowCount = UBound(dataArr1, 1) + 1
   
    ' 重新定义结果数组
    ReDim resultArr(1 To newRowCount, 1 To colCount)
   
    ' 将原有数据复制到结果数组
    For i = 1 To UBound(dataArr1, 1)
        For j = 1 To UBound(dataArr1, 2)
            resultArr(i, j) = dataArr1(i, j)
        Next j
    Next i
   
    ' 添加新行（日期）
    resultArr(newRowCount, 1) = dateStr
   
    ' 根据Sheet1的标题行填充新行的数据
    For j = 2 To colCount Step 2
        medium = ws1.Cells(1, j).Value
        If dict.exists(medium) Then
            resultArr(newRowCount, j) = dict(medium)(0)
            resultArr(newRowCount, j + 1) = dict(medium)(1)
        End If
    Next j
   
    ' 将结果写回Sheet1
    ws1.Cells(1, 1).Resize(newRowCount, colCount - 1).Value = resultArr
   
    ' 清理对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
   
    Application.ScreenUpdating = True
    MsgBox "OK！数据追加并转换完成!.用时：" & Format((Timer - t), "#0.00") & "秒", vbInformation
   
    End Sub

半百

cysczhumh 发表于 2025-5-16 17:09
不对，r-2是表2中数组的行数，在表1中的数组应是（r-2)*2

下边赋值的时候不是已经*2了吗？如果下边不乘2，上边可以乘2，但arr里的i就要除2了。

cysczhumh

半百 发表于 2025-5-17 09:33
下边赋值的时候不是已经*2了吗？如果下边不乘2，上边可以乘2，但arr里的i就要除2了。

就是把“计划和实际”分别放在奇数行和偶数行的表示

半百

cysczhumh 发表于 2025-5-17 09:43
就是把“计划和实际”分别放在奇数行和偶数行的表示

对呀，就是这个意思。