Excel VBA； 从不同位置的多个工作簿中复制特定的工作表

Question

I can copy a sheet named "Alpha" from 6 separate workbooks in the one directory, but I'm not sure how to get the code to loop around to pick up sheets in other files & locations with slightly different names.

I thought I could use :

IF sheetname LIKE " Alpha " then sheetToCopy = make this the name of the sheet I want to copy END IF

It doesn't pass the name of the sheet onto the variable though. I think it's because I'm already looping through an array, using file names & numbers.

The code below works perfectly for the 6 Alpha sheets, but it won't pick up "Y Alpha" or "Alpha XZ".

Any help would be very much appreciated!

I use the following code:

    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

From what I can see, you simply want to keep reopening the GetOpenFile dialog until the user cancels out (ie doesn't want to bring anymore files in).

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