Excel VBA； 從不同位置的多個工作簿中復制特定的工作表

Question

我可以從一個目錄中的6個單獨的工作簿中復制一個名為“ Alpha”的工作表，但是我不確定如何使代碼循環以在名稱和名稱稍有不同的其他文件和位置中提取工作表。

我以為我可以使用：

如果工作表名稱類似於“ Alpha ”，則sheetToCopy =使其成為我要復制的工作表的名稱END IF

但是，它不會將工作表的名稱傳遞給變量。 我認為這是因為我已經在使用文件名和數字遍歷數組。

下面的代碼對於6個Alpha表完全適用，但是不會選擇“ Y Alpha”或“ Alpha XZ”。

任何幫助將不勝感激！

我使用以下代碼：

    Sub AlphaTest()
    Dim MyPath 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
    Dim SaveDriveDir As String
    Dim FName As Variant
    Dim FirstCell As String
    Dim sName As String


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

    SaveDriveDir = CurDir
    ' Change this to the path\folder location of the files.
    ChDirNet "Z:\"

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then

        ' Add a new workbook with one sheet.
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1


        ' Loop through all files in the myFiles array.
        For FNum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(FNum), ReadOnly:=True)
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

            'If ActiveWorkbook.Worksheets.Name Like "*Debtors*" Then
            '    sName = ActiveWorkbook.Worksheets.Name
            'Else
            '    sName = "0"
            'End If

                With mybook.Worksheets("Alpha")
                    FirstCell = "A6"
                    Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                    ' Test if the row of the last cell is equal to or greater than the row of the first cell.
                    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                        Set sourceRange = Nothing
                    End If
                End With


                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If the 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 = FName(FNum)
                        End With

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("C" & 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 + 1
                    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
    ChDirNet SaveDriveDir
End Sub

Answer 1

從我所看到的，您只想繼續重新打開GetOpenFile對話框，直到用戶取消操作（即，不想再放入文件）。

Option Explicit

Sub AlphaTest()

    Dim FName As Variant
    'bunch of code here

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                    MultiSelect:=True)
    Do While FName <> "False"

        If IsArray(FName) Then
            'lots of code here
        End If

        FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    Loop

ExitTheSub:
    'bunch of code here
End Sub