Question

我正在为一个项目做一些研究，并且来自Ron de Bruin的some code用于合并多个工作簿。它运行得很好 - 您将所需的excel文件放在桌面上的文件夹中，运行代码，并将每个工作簿组合成一个excel摘要 - 基本上我将其用于数据收集目的。

我遇到的问题是，我似乎无法指定多个范围，而不会弄乱摘要页面。

例如，这些是我希望合并的两个工作簿/数据集：

Workbook 1

Workbook 2

最终的摘要结果应如下所示：

Should Look Like This

但是，摘要目前看起来像这样：

Results Currently Look Like This

供审核的代码和附件如下：

https://drive.google.com/drive/folders/0Bwx3ybze4rlWM3FZZHREWEh2T00?usp=sharing

当我使用此部分指定多个范围时出现问题：

Set sourceRange = .Range("A1:G2", "A7:G8")

另请注意，如果您想在计算机上对此进行测试，则需要修改您要将文件夹包含在要上传的文件中的部分：

'Fill in the path\folder where the files are
MyPath = "D:\Transfer\Transfer Test\"

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    'Fill in the path\folder where the files are
    MyPath = "D:\Budget Transfer\Transfer Test\"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    'First Row of Target Spreadsheet is Blank
    rnum = 1

    'Loop through all files in the array(myFiles)
    If FNum > 0 Then
        ' This section modified from original Ron de Bruin code to include individual items outside range per https://stackoverflow.com/questions/46718110/create-separate-row-for-each-item-when-merging-multiple-workbooks
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:G2", "A7:G8")

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A. "+1" indicates that the data on the destination sheet is shifted down one row
                        BaseWks.Cells(rnum + 1, "A").Resize(SourceRcount).Value = MyFiles(FNum)
                        ' Copy information from an indivudual cell outside of a range such as date/time started, start/final temp, and Batch ID
                        BaseWks.Cells(rnum + 1, "B").Resize(SourceRcount).Value = .Range("K1").Value
                        BaseWks.Cells(rnum + 1, "C").Resize(SourceRcount).Value = .Range("K2").Value
                        BaseWks.Cells(rnum + 1, "D").Resize(SourceRcount).Value = .Range("K3").Value
                        BaseWks.Cells(rnum + 1, "E").Resize(SourceRcount).Value = .Range("K4").Value
                        BaseWks.Cells(rnum + 1, "F").Resize(SourceRcount).Value = .Range("K5").Value
                        'Copy main data
                        BaseWks.Cells(rnum + 1, "G").Resize(SourceRcount, sourceRange.Columns.Count).Value = sourceRange.Value

                        sourceRange.Copy

                        'Set the destrange (this code is part of the code that copies and pastes formats)this is part of the original Ron de Bruin code and not part of YowE3k revision on Stackoverflow
                        Set destrange = BaseWks.Range("G" & rnum + 1)

                        'this code copies and pastes formats per https://www.rondebruin.nl/win/s3/win008.htm
                        With destrange
                            .PasteSpecial xlPasteValues
                            .PasteSpecial xlPasteFormats
                            Application.CutCopyMode = False
                        End With

                        rnum = rnum + SourceRcount
                    End If
                End With
            End If
            mybook.Close savechanges:=False

        Next FNum
        ' This line above finishes the modified code to include individual items outside range per https://stackoverflow.com/questions/46718110/create-separate-row-for-each-item-when-merging-multiple-workbooks
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

原始代码导致某些范围无法显示。使用下面的一些YowE3K代码修改代码后，范围现在显示在摘要上，但是我遇到的问题是，我指定的范围现在在两个范围之间拉入空行。 / p>

我读过指定范围如.Range（＆＃34; A1：G2＆＃34;，＆＃34; A7：G8＆＃34;）相当于指定A1的范围：G8 ，并且需要将两个单独的范围指定为＆＃34; A1：G2，A7：G8＆＃34;，但这不起作用，所以我不知所措。如何修复代码以删除这两个范围之间的空白行？我对宏不是很熟悉，所以我不太确定具体问题出在哪里。

Answer 1

在运行合并功能之前，请组织数据，使其在每个工作表上的单个范围内。根据您的示例数据，最简单的方法是对列A：G进行排序。这将把所有数据放在一起。手动完成后，运行合并时会自动运行一行或两行code can sort。

修改多个范围的Ron de Bruin Merge工作簿代码？

1 个答案: