複数の範囲のRon de Bruin Mergeブックコードを変更しますか？

Question

私はプロジェクトのためにいくつかの研究を行い、複数のワークブックをマージするためにRon de Bruinからsome codeにやってきました。これは非常にうまくいきます。あなたがデスクトップ上のフォルダに必要なExcelファイルを置いてコードを実行し、各ブックを単一のExcelサマリーにまとめます。基本的にデータ収集の目的で使用しています。

私がいる問題は、私は概要ページをめちゃくちゃにすることなく、複数の範囲を指定するように見えることができないということです。

Workbook 1

Workbook 2

、最終的な要約結果は次のようになります：

Should Look Like Thisを

は例えば、これらは私が結合しているよ2つのワークブック/データセットです

しかし、要約は現在、次のようになります。

Results Currently Look Like This

レビューのためのコードや添付ファイルは以下の通りです：

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

注場合にも：私は、このセクションで複数の範囲を指定するとき

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

問題が来ますあなたのコンピュータ上でこれをテストしたいなら、あなたがuplするファイルを含むフォルダを置いたセクションを修正する必要がありますoaded：

'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のコードを使用してコードを修正した後、範囲がサマリーに表示されるようになりましたが、指定した範囲が2つの範囲の間で空行を引っ張っている問題が発生しています。

私は、.Range（ "A1：G2"、 "A7：G8"）のような範囲を指定することはA1：G8の範囲を指定することと等価であり、2つの別々の範囲を"A1：G2、A7：G8"しかし、これはうまくいかないので、私は迷っています。これらの2つの範囲の間の空白の行を削除するには、コードをどのように修正できますか？私はマクロに慣れていないので、特定の問題がどこで発生しているかはあまりよく分かりません。それが各シート上の単一の範囲にあるよう

Answer 1

マージ機能を実行する前に、データを整理。あなたのサンプルデータに基づいて、最も簡単な方法は列A：Gをソートすることです。これにより、すべてのデータがまとめられます。手動で作業すると、マージを実行すると自動的にcode can sortの1行または2行が実行されます。