vba - 結合されたワークブックでの範囲の選択

Question

また、セル行 4 から貼り付ける結合データの「宛先」を変更する必要があります。Microsoft.com で見つけたコード (以下の回答のおかげで少し変更されています) は次のとおりです。

Sub Button1_Click()
    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:\Documents and Settings\laragon2\Desktop\Week's Routers"

   ' 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

   ' Add a new workbook with one sheet.
   Set BaseWks = ThisWorkbook.Sheets("Routers")
   rnum = 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("A4", .Range("E700").End(xlUp))
               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("b4")

                       ' 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