通过Pagebreak合并文件

我想写一个程序，通过分页符合并两个文件。 例如，如果我有两个文件A和B，每个文件有三个分页符，我想通过复制分页符1之前的文件A中的所有数据，而不是分页符1之前的文件B中的所有数据来创build一个新文件，而不是所有数据在分页1和分页2之间的文件A中，比分页1和分页2之间的文件B中的所有数据等等

我有下面的代码，它只是打开两个文件，并从文件A复制数据，而不是从文件B的数据。我不知道如何更改代码合并两个循环，以便新文件将复制所有数据在分页1之前的文件A中，分页1之前的文件B中的所有数据等等。

任何帮助将非常感激！ 谢谢！

Sub Merge_Mchpg() 'Open two workbooks Workbooks.Open (Workbooks("Filepath.xlsx") Workbooks.Open (Workbooks("Filepath.xlsx")) Dim pgBreak As Variant Dim pgBreak2 As Variant Dim pgbrk1 As Integer 'Define variable for first worksheet pagebreaks pgbrk1 = 1 Dim pgbrk2 As Integer 'Define variable for second worksheet pagebreaks Dim SourceRange As Range 'Define the source range in the newworkbook pgbrk2 = 1 Dim pgbrkAll As Integer 'Integer to keep track of location in new wkbk pgbrkAll = 1 Workbooks.Add 'Create new summary workbook Dim rowDiff As Integer 'Integer to keep track of location in new wkbk For Each pgBreak In Workbooks("test1.xlsx").Worksheets("Sheet1").HPageBreaks Set SourceRange = Workbooks("test1.xlsx").Worksheets("Sheet1").Range("A" & pgbrk1, "K" & pgBreak.Location.Row - 1) SourceRange.Copy ActiveSheet.Range("A" & pgbrkAll).PasteSpecial rowDiff = pgBreak.Location.Row - pgbrk1 pgbrk1 = pgBreak.Location.Row pgbrkAll = pgbrkAll + rowDiff + 1 Next For Each pgBreak2 In` Workbooks("test2.xlsx").Worksheets("Sheet1").HPageBreaks Set SourceRange = Workbooks("test2.xlsx").Worksheets("Sheet1").Range("A" & pgbrk2, "K" & pgBreak2.Location.Row - 1) SourceRange.Copy ActiveSheet.Range("A" & pgbrkAll).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False rowDiff = pgBreak2.Location.Row - pgbrk2 pgbrk2 = pgBreak2.Location.Row pgbrkAll = pgbrkAll + rowDiff + 1 Next End Sub 

Answer 1

下面的过程将合并两个工作簿的第一个工作表中的所有打印页面

 Sub Wsh_MergeWshByPageBreak() Const kCol As Byte = 11 'Last column of the range to merge (11 for K) Rem Variant to hold the fullname of the files to merged Dim aWbkName As Variant aWbkName = Array(kFile1, kFile2) Dim WshSrc(2) As Worksheet, RwSrcIni(2) As Long Dim WshTrg As Worksheet, RwTrgIni As Long Dim PgBreak As HPageBreak Dim SrcRng As Range Dim PgBrkMax As Integer Dim i As Integer Dim b As Byte Rem Set worksheet to hold the merge in a new workbook RwTrgIni = 1 Set WshTrg = Workbooks.Add.Worksheets(1) Rem Set Source worksheets PgBrkMax = 0 For b = 1 To 2 RwSrcIni(b) = 1 Set WshSrc(b) = Workbooks.Open(kPath & aWbkName(b)).Worksheets(1) If WshSrc(b).HPageBreaks.Count > PgBrkMax Then PgBrkMax = WshSrc(b).HPageBreaks.Count Next Rem Merge Worksheets PrintArea by Page For i = 1 To PgBrkMax For b = 1 To 2 Set PgBreak = Nothing On Error Resume Next Set PgBreak = WshSrc(b).HPageBreaks(i) On Error GoTo 0 If Not (PgBreak Is Nothing) Then With WshSrc(b) Set SrcRng = Range(.Cells(RwSrcIni(b), 1), .Cells(-1 + PgBreak.Location.Row, kCol)) SrcRng.Copy WshTrg.Cells(RwTrgIni, 1).PasteSpecial Paste:=xlPasteValues RwSrcIni(b) = PgBreak.Location.Row RwTrgIni = 1 + RwTrgIni + SrcRng.Rows.Count End With: End If: Next: Next End Sub