您的个人资料说您编程，所以我认为问题是您不知道 VBA 语法。我对您的表格做出了假设，但我也假设如果我的假设不正确，您可以修改我的代码。
我在工作表 TblSrc 中创建了您的数据副本。
表格1：
表 2：
我复制了这些行，因此每个主表中有八个子表。该代码依赖于两个主表之间的一对一匹配。我不检查两个子表是否匹配。这对于任何实际时间来说都不够数据，但值得一提的是，下面的宏需要 0.03 秒来复制四对子表来创建：
我通过合并单元格来创建连字符行，将第一个单元格设置为 '- 并将水平对齐设置为 Fill。我通过检查 A 列的第一个字符是否为连字符来识别分隔符行。连字符前的单引号是为了阻止它看起来像一个无效的负数。它不是单元格值的一部分。
此宏不是解决此问题的最快方法，但会将子表中的任何格式从源复制到目标。
宏中有一些注释，但可能还不够。我建议您使用 F5（运行到下一个断点）和 F8（执行下一个语句）逐步执行宏。
带着问题回来，我会改进答案。如果您可以提供有关您的数据的更多信息，我可能会向您展示其他方法。
警告现在是 21:45，我不确定我明天的互联网访问情况。我会尽快回答问题。
选项显式 Sub CombineTables()
Dim CellValue() As Variant
Dim ColCrnt As Long
Dim ColMax As Long
Dim Found As Boolean
Dim RngStgHeader1 As String
Dim RngStgHeader2 As String
Dim RngStgHeaderX As String
Dim RowDestCrnt As Long
Dim RowSrcSubTab1End As Long
Dim RowSrcSubTab1Start As Long
Dim RowSrcSubTab2End As Long
Dim RowSrcSubTab2Start As Long
Dim RowSrcTab1Crnt As Long
Dim RowSrcTab2Crnt As Long
Dim RowSrcTab1End As Long
Dim RowSrcTab1Start As Long
Dim RowSrcTab2End As Long
Dim RowSrcTab2Start As Long
Dim timeStart As Double
Application.EnableEvents = False ' Prevents any event routine being called
Application.ScreenUpdating = False ' Screen updating causes flicker and is slow
timeStart = Timer ' Seconds since midnight
' Gather information from source worksheet
With Worksheets("TblSrc")
' These statements find the last row and the last column containing a value
RowSrcTab2End = .Cells.Find("*", .Range("A1"), xlFormulas, , _
xlByRows, xlPrevious).Row
ColMax = .Cells.Find("*", .Range("A1"), xlFormulas, , _
xlByColumns, xlPrevious).Column
CellValue = .Range(.Cells(1, 1), .Cells(RowSrcTab2End, ColMax)).Value
' CellValue is now a 2D array containing every value from the used range.
' The first dimension will be for the rows and the second for the columns.
' The lower bound of each dimension will be 1. The upper bounds will be
' RowSrcTab2End and ColMax. Having the rows as the first dimension is
' unusual is the nature of arrays loaded from or to a worksheet.
' I did not have to copy the data to an array. I could have done so
' because I believe searching for sub tables will be sufficiently faster
' to make this a sensible choice.
End With
' Find the start of the main tables.
For RowSrcTab1Crnt = 1 To RowSrcTab2End
If CellValue(RowSrcTab1Crnt, 1) = "projectId" And _
CellValue(RowSrcTab1Crnt, 2) = "start" Then
RowSrcTab1Start = RowSrcTab1Crnt
Exit For
End If
Next
For RowSrcTab2Crnt = RowSrcTab1Crnt + 1 To RowSrcTab2End
If CellValue(RowSrcTab2Crnt, 1) = "projectId" And _
CellValue(RowSrcTab2Crnt, 2) = "expenseCode" Then
RowSrcTab2Start = RowSrcTab2Crnt
Exit For
End If
Next
RowSrcTab1End = RowSrcTab2Start - 1
' Output values found to the Immediate window as a check
Debug.Print "Table 1 rows: " & RowSrcTab1Start & " - " & RowSrcTab1End
Debug.Print "Table 2 rows: " & RowSrcTab2Start & " - " & RowSrcTab2End
With Worksheets("TblDest")
' Clear current contents of destination sheet
.Cells.EntireRow.Delete
End With
' Build range strings for table headers because
' they are needed for every projectId
RngStgHeader1 = "A" & RowSrcTab1Start & ":" & _
ColNumToCode(ColMax) & RowSrcTab1Start
RngStgHeader2 = "A" & RowSrcTab2Start & ":" & _
ColNumToCode(ColMax) & RowSrcTab2Start
RowSrcTab1Crnt = RowSrcTab1Start + 1 ' \ Start point for search
RowSrcTab2Crnt = RowSrcTab2Start + 1 ' / for first sub tables
RowDestCrnt = 1 ' Position for first output sub tables
Do While True
' Search for start of next sub table 1
Found = False
Do While RowSrcTab1Crnt < RowSrcTab2Start
If CellValue(RowSrcTab1Crnt, 1) <> "" And _
Left(CellValue(RowSrcTab1Crnt, 1), 1) <> "-" Then
' Assume next table 1 row with column A not empty and not starting
' with a hyphen is the start of next table 1 sub table
Found = True
RowSrcSubTab1Start = RowSrcTab1Crnt
RowSrcTab1Crnt = RowSrcTab1Crnt + 1 ' Prepare for search for end
Exit Do
End If
RowSrcTab1Crnt = RowSrcTab1Crnt + 1
Loop
If Not Found Then
' No next sub table 1 found. All done.
Exit Do
End If
' Search for end of this sub table 1
Found = False
Do While RowSrcTab1Crnt < RowSrcTab2Start
If LCase(Left(CellValue(RowSrcTab1Crnt, 1), 5)) = "total" Then
Found = True
RowSrcSubTab1End = RowSrcTab1Crnt
RowSrcTab1Crnt = RowSrcTab1Crnt + 1 ' Prepare for next loop
Exit Do
End If
RowSrcTab1Crnt = RowSrcTab1Crnt + 1
Loop
If Not Found Then
' End of table not found. Either data error or program error
Debug.Assert False ' Interpreter will stop here to allow
' examination of variables
Exit Do
End If
' Search for start of next sub table 2
Found = False
Do While RowSrcTab2Crnt < RowSrcTab2End
If CellValue(RowSrcTab2Crnt, 1) <> "" And _
Left(CellValue(RowSrcTab2Crnt, 1), 1) <> "-" Then
' Assume next table 2 row with column A not empty and not starting
' with a hyphen is the start of next table 2 sub table
Found = True
RowSrcSubTab2Start = RowSrcTab2Crnt
RowSrcTab2Crnt = RowSrcTab2Crnt + 1 ' Prepare for search for end
Exit Do
End If
RowSrcTab2Crnt = RowSrcTab2Crnt + 1
Loop
If Not Found Then
' No next sub table 2 found. Have table 1 so have data or program error.
Debug.Assert False ' Interpreter will stop here to allow
' examination of variables
Exit Do
End If
' Search for end of this sub table 2
Found = False
Do While RowSrcTab2Crnt < RowSrcTab2End
If LCase(Left(CellValue(RowSrcTab2Crnt, 1), 5)) = "total" Then
Found = True
RowSrcSubTab2End = RowSrcTab2Crnt
RowSrcTab2Crnt = RowSrcTab2Crnt + 1 ' Prepare for next loop
Exit Do
End If
RowSrcTab2Crnt = RowSrcTab2Crnt + 1
Loop
If Not Found Then
' End of table not found. Either data error or program error
Debug.Assert False ' Interpreter will stop here to allow
' examination of variables
Exit Do
End If
' Have start and end of next sub tables.
' Copy header row for table 1
Worksheets("TblSrc").Range(RngStgHeader1).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + 1
' Copy sub table 1 plus rows before and after which should be dividing rows
RngStgHeaderX = "A" & RowSrcSubTab1Start - 1 & ":" & _
ColNumToCode(ColMax) & RowSrcSubTab1End + 1
Worksheets("TblSrc").Range(RngStgHeaderX).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + RowSrcSubTab1End - RowSrcSubTab1Start + 4
' Copy header row for table 2
Worksheets("TblSrc").Range(RngStgHeader2).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + 1
' Copy sub table 2 plus rows before and after which should be dividing rows
RngStgHeaderX = "A" & RowSrcSubTab2Start - 1 & ":" & _
ColNumToCode(ColMax) & RowSrcSubTab2End + 1
Worksheets("TblSrc").Range(RngStgHeaderX).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + RowSrcSubTab2End - RowSrcSubTab2Start + 3
' Warning there is a limit of 1026 on the number of horizontal page breaks
Worksheets("TblDest").HPageBreaks.Add _
Before:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
Loop
Debug.Print Timer - timeStart
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
' Convert column number (such as 1, 2, 27, etc.) to
' column code (such as A, B, AA, etc.)
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function