VBAで複数の範囲を選択する - 複数のブックを1つのマスターブックに統合する

Question

同じフォルダー内のいくつかのブックをチャート作成目的でマスターブックに統合しようとしています。私はこれを達成するためにRon De Bruin's codeを使用しています。これまでのところすべてがうまくいきます。私は自分のアプリケーションに完璧なものにするためにもう一つの機能が必要です。

コードでは、選択したソース範囲が大規模な範囲（B12：H316）にあり、ピボットテーブルを使用してそれをフィルタリングする必要があります。実際には、B12：H12、B20：H20、B316：H316のみが必要です。 Set SourceRange = .Range("B12:H12","B20:H20","B316:H316")と同様に、Set SourceRange = Union(.Range("B12:H12"), .Range("B20:H20"), .Range("B316:H316"))のような多くの調整を試しましたが、これまでのところ何も動作しません。

コードラインを調整して、B12：H12、B20：H20、およびB316：H316をソース範囲として選択できるようにしました。フォルダ？

私は、Ron De Bruinには複数の範囲に対応するアドイン機能があることを理解します。しかし、会社の方針のせいで私はそれを使うことができません。私は与えられた助けの任意の形式に感謝

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 

' Change this to the path\folder location of your files. 
MyPath = "C:\Users\Captain\Desktop\Target Test" 

' Add a slash at the end of the path if needed. 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\" 
End If 

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

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

' Set various application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Use existing sheet 
Set BaseWks = Workbooks("SPC.xlsm").Worksheets("RawData") 
rnum = BaseWks.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 


' Loop through all files in the myFiles array. 
If FNum > 0 Then 
    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 
      On Error Resume Next 

      ' Change this range to fit your own needs. 

      With mybook.Worksheets(1) 

      Set SourceRange = .Range("B12:H316") 

       End With 

      If Err.Number > 0 Then 
       Err.Clear 
       Set SourceRange = Nothing 
      Else 
       ' If source range uses all columns then 
       ' skip this file. 
       If SourceRange.Columns.Count >= BaseWks.Columns.Count Then 
        Set SourceRange = Nothing 
       End If 
      End If 
      On Error GoTo 0 

      If Not SourceRange Is Nothing Then 

       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. 
        With SourceRange 
         BaseWks.Cells(rnum, "A"). _ 
           Resize(.Rows.Count).Value = MyFiles(FNum) 
        End With 

        ' Set the destination range. 
        Set DestRange = BaseWks.Range("B" & rnum) 

        ' Copy the values from the source range 
        ' to the destination range. 
        With SourceRange 
         Set DestRange = DestRange. _ 
             Resize(.Rows.Count, .Columns.Count) 
        End With 
        DestRange.Value = SourceRange.Value 

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

    Next FNum 
    BaseWks.Columns.AutoFit 
End If 

    ExitTheSub: 
' Restore the application properties. 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 
End Sub 

：

以下は、私が今抱えている私のコードです。あなたのお時間をありがとう。

Answer 1

Set SourceRange = Union(.Range("B12:H12"), .Range("B20:H20"), .Range("B316:H316"))を使用すると動作しますが、いくつかの奇妙な副作用があります。連合が「継続的」な範囲（たとえば、「B12：H15」）を作成した場合、すべて正常に動作します。行にギャップがあるため、通常期待される結果が得られません。

SourceRange.Rows.Countは1と評価されるため、SourceRCountの値は正しくありません。このスニペットを交換し

1）...これで

SourceRcount = SourceRange.Rows.Count 

... ...

Dim aRow as Range 
SourceRCount = 0 
For Each aRow In SourceRange.Rows 
    SourceRCount = SourceRCount + 1 
Next aRow 

2）また、次のスニペットが必要とする補正...

With SourceRange 
     BaseWks.Cells(rnum, "A"). _ 
      Resize(.Rows.Count).Value = MyFiles(FNum) 
    End With 

...おそらくこれ...

BaseWks.Cells(rnum, "A").Resize(SourceRCount).Value = MyFiles(FNum) 

3）このスニペット...

With SourceRange 
     Set DestRange = DestRange. _ 
         Resize(.Rows.Count, .Columns.Count) 
    End With 

...（Columns.Countが正常に動作します）になる必要があります...

Set DestRange = DestRange.Resize(SourceRCount, SourceRange.Columns.Count) 

4）最後に、この割り当てとして機能しません期待...

DestRange.Value = SourceRange.Value 

...と

...に変更する必要があります

Dim RCount as long 
RCount = 0 
For Each aRow In SourceRange.Rows 
    RCount = RCount + 1 
    DestRange.Rows(RCount).Value = aRow.Value 
Next aRow