你的個人資料說你編程，所以我認爲問題是你不知道VBA的語法。我已經假設你的表格，但我也假設你可以修改我的代碼，如果我的假設是不正確的。
我在工作表TblSrc中創建了一份數據。
表1：
表2：
我複製這些行，所以我有在各主表八個子表。代碼依賴於兩個主表之間的一對一匹配。我不檢查兩個子表匹配。這不是任何真正的時機，但足夠的數據，有什麼值得注意的是，下面的宏把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
你能發佈一個鏈接到一個虛擬樣品組數據？ –
不幸的是，沒有。 ：/ – Kraz
做同樣的projectIds在同一個序列中出現在兩個表中嗎？如果沒有，projectIds是否按照遞增的順序排列，因此如果缺少正確的行爲可以確定？這應該不需要很長時間來編程（遠遠少於8小時）或者使用VBA運行？ –