时间戳

首页 > 解决方案 > 我试图让这个宏包括从工作簿中的多个工作表复制数据的能力，但它只会从第一个工作表复制

vba - 我试图让这个宏包括从工作簿中的多个工作表复制数据的能力，但它只会从第一个工作表复制

问题描述

这是我下面的数据。代码工作不符合我的要求。我需要添加允许我从 1 个工作簿中的多个工作表中提取数据的功能，但目前它只会从 1 个工作簿中的 1 个工作表中提取数据。我已经包含了通过不同工作表的代码，但到目前为止，代码只会从 1 个工作簿中的 1 个工作表中提取数据。任何帮助是极大的赞赏。谢谢！

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\mp180423\Desktop\Gas"

    ' 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 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    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


            Dim ws As Worksheet

            For Each ws In Worksheets
            ws.Activate
            Debug.Print ws.Name

            Next



            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                With mybook.Worksheets(3)
                    Set sourceRange = .Range("A15:B20")
                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.
                        For Each ws In Worksheets
                        ws.Activate
                        Debug.Print ws.Name
                        Next

                        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

        Range("B1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$C$66").AutoFilter Field:=2, Criteria1:= _
        "Kilowatt hours used Current period"


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


MsgBox ("Merge Completed.")
End Sub

标签： vbaexcel

解决方案

我希望此代码正确工作的单个工作簿中的单个工作表将是唯一具有至少 3 个工作表的工作簿。

选择您拥有的范围时：

With mybook.Worksheets(3)
    Set sourceRange = .Range("A15:B20")
End With

请注意，这会将数据限制在每个工作簿中仅第三个（第三个）工作表的范围内。

另请注意，在前面的行中，您有：

On Error Resume Next

这将有效地掩盖试图从所有不存在的第三个工作表中提取数据的错误。对于具有至少 3 个工作表的工作簿，由于With mybook.Worksheets(3)已硬编码到您的代码中，因此这是从中提取数据的唯一工作表。

（并且该工作簿中的每个工作表都没有重复它的原因是因为通过工作表的循环仅限于Debug.Print行。数据移动的代码只为每个工作簿循环一次）

下面，您将看到三 (3) 个部分：

  1. 更改详细信息。

    • 这是为了帮助突出我对您的代码所做的更改，以便它循环遍历每个工作表的数据移动，从每个工作表中提取一次。

  2. 已更正

    • 这是为了便于复制/粘贴代码

  3. 原来的

    • 这是为了维护我基于我的答案的原始代码的副本（以防发生更改）。

变更详情

来自原文：

Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0


Dim ws As Worksheet

For Each ws In Worksheets
ws.Activate
Debug.Print ws.Name

Next

If Not mybook Is Nothing Then

    On Error Resume Next

     ' Change this range to fit your own needs.
     With mybook.Worksheets(3)
          Set sourceRange = .Range("A15:B20")
     End With

变成：

Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

Dim ws As Worksheet

If Not mybook Is Nothing Then

    For Each ws In Worksheets
        On Error Resume Next

        ' Change this range to fit your own needs.
        With ws
            Set sourceRange = .Range("A15:B20")
        End With
  • 上半场：
    • 尽管我保留了Dim ws As Worksheet，但我删除了所有工作表中的 Debug.Print 循环，因为它对任何其他代码都没有影响。
  • 下半部分：
    • For Each ws In Worksheets在功能代码周围添加了一个（需要Next ws在上面添加mybook.Close savechanges:=False），并将with语句With mybook.Worksheets(3)从With ws

由于Debug.Print在将文件名添加到 A 列之前还有另一个无关循环，因此我将其替换Debug.Print ws.Name & ": #" & FNum为更多信息。

已更正

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\mp180423\Desktop\Gas"

    ' 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 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    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

            ' Added cycle through worksheets
            Dim ws As Worksheet
            If Not mybook Is Nothing Then
                For Each ws In Worksheets

                    On Error Resume Next

                     ' Change this range to fit your own needs.
                    ' Shifted reference to current worksheet-of-interest
                    With ws
                        Set sourceRange = .Range("A15:B20")
                    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

                            ' Prints file name and index number in immediate window.
                            Debug.Print ws.Name & ": #" & FNum

                            ' 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
                'Cycles through next worksheet-of-interest
                Next ws
                mybook.Close savechanges:=False

            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If

        Range("B1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$C$66").AutoFilter Field:=2, Criteria1:= _
        "Kilowatt hours used Current period"


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


MsgBox ("Merge Completed.")
End Sub

原来的

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\mp180423\Desktop\Gas"

    ' 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 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    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


            Dim ws As Worksheet

            For Each ws In Worksheets
            ws.Activate
            Debug.Print ws.Name

            Next



            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                With mybook.Worksheets(3)
                    Set sourceRange = .Range("A15:B20")
                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.
                        For Each ws In Worksheets
                        ws.Activate
                        Debug.Print ws.Name
                        Next

                        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

        Range("B1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$C$66").AutoFilter Field:=2, Criteria1:= _
        "Kilowatt hours used Current period"


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


MsgBox ("Merge Completed.")
End Sub

推荐阅读