用另一个工作表单元格上的数据填充一个工作表的多个单元格条目

Question

我有一个电子表格#1，它在许多列中有数据行和值，例如 A 列是 ORDER DATE，B 列是区域 C 列作为代表等。（总共 M 行）

我有另一个电子表格＃2，其中包含其他列和许多行。 A 列是项目，B 列是区域，C 列是项目数，依此类推（总共 N 行）

我想要一个宏，它将用工作表 2 中的所有数据填充工作表 1 中的数据。例如，如果工作表 1 中有 10 行，工作表 2 中有五行，那么工作表 3 必须有 50 行，即工作表 2 的所有五行必须填充工作表 1 的每一行。

注意：列数不是静态的（对于两个工作表中的列数，它们没有固定的结构）

我提供了截图以便更好地理解（表 1、表 2 和表 3）：

我试图明智地附加数据列，但我无法为工作表 2 中的数据创建重复当前我的代码仅连接工作表 1 和工作表 2 的列，但不能创建 m X n 行

Sub ColumnsPaste()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long

Application.ScreenUpdating = False

Set Destination = Worksheets.Add(after:=Worksheets("Sheet1"))
Destination.Name = "Sheet3"

For Each Source In ThisWorkbook.Worksheets        
    If Source.Name <> "Sheet3" Then
        Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column
    
        If Last = 1 Then
            Source.UsedRange.Copy Destination.Columns(Last)
        Else
            Source.UsedRange.Copy Destination.Columns(Last + 1)
        End If
    End If
Next

Columns.AutoFit

Application.ScreenUpdating = True
End Sub

我的 VBA 代码输出：

Answer 1

请使用下一个代码。 它会足够快，仅使用剪贴板来复制标题。 它假定要处理的范围存在于“A:C”列（从第二行开始）并在“D:D”列中返回：

Sub CombiteSheets()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lastR1 As Long, lastR2 As Long, lastR3 As Long
  Dim lastCol1 As Long, lastCol2 As Long, repRows As Long, arr2, i As Long, iRow As Long
  
   Set sh1 = ActiveSheet 'use here the sheet you need
   Set sh2 = sh1.Next       'use here the sheet you need
   Set sh3 = sh2.Next       'the same...
   
    lastR1 = sh1.Range("A" & sh1.rows.count).End(xlUp).row  'last row on the first sheet
    lastR2 = sh2.Range("A" & sh2.rows.count).End(xlUp).row  'last row on the second sheet
    lastCol1 = sh1.cells(1, sh1.Columns.count).End(xlToLeft).Column 'last column on the first sheet
    lastCol2 = sh2.cells(1, sh2.Columns.count).End(xlToLeft).Column 'last columln on the second sheet
    repRows = lastR2 - 1
    
    arr2 = sh2.Range("A2", sh2.cells(lastR2, lastCol2)).value 'place the range in an array for faster processing
    
    On Error GoTo SaveExit
    'some code optimization:
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.EnableEvents = False
    
    For i = 2 To lastR1
        sh3.Range("A" & i + iRow).Resize(repRows, lastCol1).value = _
                                   sh1.Range("A" & i, sh1.cells(i, lastCol1)).value
        sh3.cells(i + iRow, lastCol1 + 1).Resize(UBound(arr2), UBound(arr2, 2)).value = arr2
        iRow = iRow + repRows - 1
    Next i
    
    'copy headers:
    sh1.Range("A1", sh1.cells(1, lastCol1)).Copy sh3.Range("A1")
    sh2.Range("A1", sh2.cells(1, lastCol2)).Copy sh3.cells(1, lastCol1 + 1)
    
    'a little formatting:
    someFormat sh3.Range("A1", sh3.cells(UBound(arr2) * (lastR1 - 1) + 1, lastCol1 + lastCol2))

    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.EnableEvents = True
    
    MsgBox "Ready..."
    Exit Sub
    
SaveExit:
   Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.EnableEvents = True
   MsgBox err.Description, vbCritical, err.Number
End Sub

Private Sub someFormat(rng As Range) 'formatting the returned range
 Dim i As Long
 rng.EntireColumn.AutoFit
 For i = 7 To 12
        With rng.Borders(i)
            .LineStyle = xlContinuous
            .ColorIndex = 47
            .Weight = xlThin
        End With
        Next i
End Sub

请在测试后发送一些反馈...