Excel VBA; copying specific worksheets from multiple workbooks in different locations - 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 (i.e. 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