如何将特定范围单元格从多张纸复制到一张纸？

Question

我在一个文件夹中有一个主工作簿，在另一个文件夹中有 100 多个子工作簿。

每周我都需要将特定范围的单元格从子工作簿（所有子簿的工作表名称相同）复制到主工作簿（特定工作表）。

我试了几个样品，但没有成功。

Answer 1

我完全同意那些告诉你没有人会为你编写代码的人的观点，但你很幸运，我已经编写了代码，并且可能还有其他人在寻找相同的信息，所以就在这里。 将代码放到主工作簿中的模块中，并按照注释替换一些数据：

Option Explicit

Sub GoThroughFilesAndCopyData()

Dim BrowseFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim shtWork As Worksheet
Dim lngRow As Long
Dim i As Long: i = 1
Dim strPath As String
Dim MasterSheet As Worksheet
Dim ChildSheet As Worksheet

Application.ScreenUpdating = False

    ' selecting the folder to look files in
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder with child workbooks"
        .Show
        On Error Resume Next
        Err.Clear
        BrowseFolder = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "You didn't select anything!"
            Application.ScreenUpdating = True
            Exit Sub
        End If
        On Error GoTo 0
    End With

    Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
    Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object

    Set MasterSheet = ThisWorkbook.Sheets("masterworksheet_name") 'replace masterworksheet_name with the name of your worksheet in master workbook

    For Each FileItem In oFolder.Files 'looking through each file

        If UCase(FileItem.Name) Like "*.XLS*" Then 'try open only excel files

            i = MasterSheet.Cells(Rows.Count, 1).End(xlUp).row + 1 ' find last not empty row and get a next one which is empty
            Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
            Set ChildSheet = Workbooks(FileItem.Name).Sheets("worksheet_name") 'worksheet_name - replace with child sheet name

            With ChildSheet ' replace your_range_to_copy with the range on a child sheet you want to copy
                Range("your_range_to_copy").Copy Destination:=MasterSheet.Cells(i, column_number) 'i - is the number of last empty row, replace column_number - must be the column number of range to insert
                .Parent.Close SaveChanges:=False 'close child workbook without saving
            End With

        End If
    Next

    Application.ScreenUpdating = True

End Sub

Answer 2

这将做你想要的。

复制每个工作表的范围

注意：此示例使用 function LastRow

This example copy the range A1:G1 from each worksheet.

更改此代码行中的范围

'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A1:G1")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

还。 . .

'Common Functions required for all routines

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function