如何用VBA将表格数据按指定格式复制到新工作表

我有一张包含参考编号、数量、日期的确认表格，需将数据按如下规则复制到新工作表：

• A列为参考编号，B列为数量，C列为对应日期（如原表C4单元格的日期）
• 每个参考编号单独占一行，之后重复参考编号与数量列表，对应第二个日期（如原表D4单元格），以此类推处理全部5个日期

当前我的代码只能把A列和C列内容并列显示，无法将日期填入第三列，也没法把所有数据按要求纵向排列成一个列表，希望用循环实现但不知道怎么写。

当前代码 #

Sub EDIinvullen()

     Application.ScreenUpdating = False
     
     Worksheets("OmzettingEDI-1").Range("A1:F200").clear
     
    
    Dim lastrow As Integer

    Dim wksSource As Worksheet, wksDest As Worksheet
    Dim rngStart As Range, rngSourcedat1 As Range, rngDest1 As Range, rngSourcedat2 As Range, rgnDest2 As     Range, rngDatum1 As Range

    Set wksSource = ActiveWorkbook.Sheets("Bevestiging P&G")
    Set wksDest1 = ActiveWorkbook.Sheets("OmzettingEDI-1")


    lastrow = wksSource.Range("A4").End(xlDown).Row

    Set rngSourcedata = wksSource.Range("C4:G" & lastrow) 'gebruikt om alle lege velden met 0 in te vullen
    Set rngSourcedat1 = wksSource.Range("A5:A" & lastrow & ",C5:C" & lastrow) 'referentie en aantal van datum 1
    Set rngSourcedat2 = wksSource.Range("A5:A" & lastrow & ",D5:D" & lastrow) 'referentie en aantal van datum 2
    Set rngDatum1 = wksSource.Range("C4") 'datum 1 - werkt niet

On Error Resume Next
    InputValue = 0
    For Each cell In rngSourcedata
    If IsEmpty(cell) Then
    cell.Value = InputValue
    End If
    Next

    Set rngDest1 = wksDest1.Range("A1")
    rngSourcedat1.Copy
    rngDest1.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

  rngDatum1 = wksDest1.Range("C1")
   rngDatum1.Copy
  rngDest1.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
    Set rngDest2 = wksDest1.Range("D1")
    rngSourcedat2.Copy
    rngDest2.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

  Application.CutCopyMode = False
  Application.ScreenUpdating = True

End Sub

修正后的代码 #

Sub EDIinvullen()
    Application.ScreenUpdating = False
    
    Dim wksSource As Worksheet, wksDest As Worksheet
    Dim lastRowSource As Long, destRow As Long
    Dim dateCol As Integer, sourceRow As Long
    Dim currentDate As Date
    
    ' 指定源工作表和目标工作表
    Set wksSource = ActiveWorkbook.Sheets("Bevestiging P&G")
    Set wksDest = ActiveWorkbook.Sheets("OmzettingEDI-1")
    
    ' 清空目标表指定区域
    wksDest.Range("A1:F200").Clear
    
    ' 获取源数据最后一行（参考编号的末尾行）
    lastRowSource = wksSource.Range("A4").End(xlDown).Row
    
    ' 填充源数据中的空值为0
    For Each cell In wksSource.Range("C4:G" & lastRowSource)
        If IsEmpty(cell) Then cell.Value = 0
    Next
    
    ' 初始化目标表写入起始行
    destRow = 1
    
    ' 循环处理5个日期列（原表C到G列，对应列号3到7）
    For dateCol = 3 To 7
        currentDate = wksSource.Cells(4, dateCol).Value
        
        ' 遍历所有参考编号行
        For sourceRow = 5 To lastRowSource
            ' 写入参考编号
            wksDest.Cells(destRow, 1).Value = wksSource.Cells(sourceRow, 1).Value
            ' 写入对应日期的数量
            wksDest.Cells(destRow, 2).Value = wksSource.Cells(sourceRow, dateCol).Value
            ' 写入当前日期
            wksDest.Cells(destRow, 3).Value = currentDate
            
            destRow = destRow + 1
        Next sourceRow
    Next dateCol
    
    Application.ScreenUpdating = True
End Sub

关键说明 #

1. 用嵌套循环实现：外层循环遍历每个日期列，内层循环遍历所有参考编号行，逐个写入目标表
2. 用destRow自动维护目标表的写入位置，无需手动计算起始行
3. 直接单元格赋值代替复制粘贴，提升代码效率
4. 移除不必要的On Error Resume Next，避免隐藏潜在错误

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