あなたのプロフィールはあなたがプログラムしていると言っているので、問題はあなたがVBA構文を知らないということだと思います。私はあなたのテーブルについて仮定を立てましたが、私の仮定が正しくない場合はコードを修正できると思います。
ワークシートTblSrcにデータのコピーを作成しました。
表1：
表2：
これらの行を複製したので、各メインテーブルに8つのサブテーブルがあります。このコードは、2つのメインテーブル間で1対1の一致があることに依存しています。2つのサブテーブルが一致するかどうかはチェックしません。これは実際のタイミングには十分なデータではありませんが、価値があるので、以下のマクロは、作成するサブテーブルの4つのペアをコピーするのに0.03秒かかりました。
セルを結合し、最初のセルを'-に設定し、水平方向の配置を[塗りつぶし]に設定して、ハイフンの行を作成しました。列Aの最初の文字がハイフンであるかどうかを確認して、区切り行を識別します。ハイフンの前の単一引用符は、無効な負の数のように見えるのを防ぐためのものです。セル値の一部ではありません。
このマクロは、この問題に対する最速のアプローチではありませんが、サブテーブルのフォーマットをソースから宛先にコピーします。
マクロ内にいくつかのコメントがありますが、おそらく十分ではありません。F5（次のブレークポイントまで実行）とF8（次のステートメントを実行）でマクロをステップスルーすることをお勧めします。
質問を持って戻ってきてください、そして私は私の答えを改善します。あなたがあなたのデータについてより多くの情報を与えることができれば、私はあなたに他のアプローチを示すことができるかもしれません。
警告はここでは21:45で、明日のインターネットアクセスについてはよくわかりません。できるだけ早く質問に答えます。
オプション明示的サブ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