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

Answer 1

源范围正在紧接着之后的行中设置：' Change this range to fit your own needs.它看起来像这样：

Set sourceRange = .Range("A1:C1")

目的地正在评论后面的行中设置：' Set the destination range.看起来像这样：

Set destrange = BaseWks.Range("B" & rnum)

编辑以下是一个示例。创建一个空的工作簿。在工作表1的单元格A1：A5中放置一些值。执行此操作：

Sub CopyRangeToRange()
    Dim sourceRange As Range
    Dim destRange As Range

    Set sourceRange = Range("A1:A5")

    Set destRange = Sheets(2).Range("A1")

    With sourceRange
        Set destRange = destRange.Resize( _
            .Rows.Count, .Columns.Count)
    End With

    Sheets(2).Activate
    destRange.Activate
    destRange.Value = sourceRange.Value

End Sub

这与我上面提出的方法完全相同。如果这样可行，但是你编写的宏不起作用，你需要调试它出错的地方，因为方法是相同的。

编辑＃2

在您的工作簿上尝试此操作后，我认为这就是您所追求的。我相信我评论了我的所有更改，您可以通过'##评论找到这些更改。几乎所有更改都在With sourcerange块中应用。我还将rnum的初始值更改为4，因为这似乎是数据应该开始粘贴到路由器工作表中的位置，并修改了循环中每个文件的rnum递增方式。 / p>

Sub Button1_Click()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long, mybook As Workbook
Dim 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

' Set the destination worksheet:'
Set BaseWks = ThisWorkbook.Sheets("Routers")

'## set rnum to 4 because we begin pasting data in row 4... ##'
rnum = 4

' 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("E4:E700").End(xlUp))  '## changed dz ##'
            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.
                    BaseWks.Activate
                    With sourceRange
                    ''## changed to make this range the same number of rows as sourceRange ##'
                        BaseWks.Cells(rnum, 1). _
                                Resize(.Rows.Count).Value = MyFiles(FNum)
                    '## moved this code and changed to begin at the last non-blank row in column A, but use column B ##'
                    '## resize the destrange to the same dimensions as sourcerange ##'
                        Set destrange = BaseWks.Cells(rnum, 1). _
                                Resize(.Rows.Count, .Columns.Count).Offset(, 1)
                    '## Insert the source values in the destination range ##'
                        destRange.Value = .Value
                    '## increment rnum to the next appropriate value ##'
                        rnum = rnum + .Rows.Count
                    End With

                    '## Removed as redundant
                    'With sourceRange
                    '    Set destrange = destrange. _
                    '                    Resize(.Rows.Count, .Columns.Count)
                    'End With

                    ' Copy the values from the source range
                    ' to the destination range.
                    '## This has been moved to above. ##
                    ' destrange.Value = sourceRange.Value


                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

在合并的工作簿上选择范围

1 个答案: