Try...
In a standard module:
Option Explicit
Sub CopySheets()
Dim wkbSource As Workbook, wkbTarget As Workbook
Dim sPath As String, sWksNames As String, sz As String
Dim Dlg, Wks, sExt, f, vCalcMode
Dim bXLfile As Boolean
'Edit these to suit
'==============================================
Const sFileTypes As String = ".xls,.xlsx"
Const sTargetWkbName As String = "zbiorczy.xls"
Const sBeginChar As String = "X"
'==============================================
'Make sure the target wkb is open
On Error Resume Next
Set wkbTarget = Workbooks(sTargetWkbName) '//edit to suit
On Error GoTo 0
If wkbTarget Is Nothing Then
sz = "The file '" & sTargetWkbName & "' is not open."
sz = sz & vbCrLf & vbCrLf
sz = sz & "Please open the file and try again."
MsgBox sz, vbCritical: Exit Sub
End If
With Application
.ScreenUpdating = False
vCalcMode = .Calculation: .Calculation = xlCalculationManual
End With
On Error GoTo ErrExit
'Get the folder
Set Dlg = Application.FileDialog(4)
With Dlg
If .Show = False Then Exit Sub '//user cancelled
sPath = .SelectedItems(1)
End With
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
'Get the files
f = Dir(sPath, 7)
Do While f <> ""
'Filter for filetypes
bXLfile = (InStr(1, sFileTypes, _
Mid$(f, InStrRev(f, ".", , vbTextCompare))) > 0)
If bXLfile Then
Application.StatusBar = "Processing File: " & f
Set wkbSource = Workbooks.Open(sPath & f)
'Get names of sheets to copy
For Each Wks In wkbSource.Worksheets
If Left$(Wks.Name, 1) = sBeginChar _
Then sWksNames = sWksNames & "," & Wks.Name
Next 'wks
If Not sWksNames = "" Then
Call GroupSheets(Mid$(sWksNames, 2), , wkbSource)
Windows(f).SelectedSheets.Copy _
After:=wkbTarget.Sheets(wkbTarget.Sheets.Count)
sWksNames = "" '//clear the list
End If 'Not sWksNames = ""
wkbSource.Close SaveChanges:=False
End If 'bXLfile
f = Dir '//get the next file
Loop
ErrExit:
'Cleanup
Set wkbSource = Nothing: Set wkbTarget = Nothing: Set Dlg = Nothing
With Application
.StatusBar = False: .ScreenUpdating = True: .Calculation =
vCalcMode
End With 'Application
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GroupSheets()
' This procedure requires only the necessary amount of coding be used
' in the Caller. By default, it requires passing only the first arg.
' Use Example: GroupSheets "Sheet1,Sheet3"
' creates a group of only those sheets.
' To group all sheets in a workbook except those sheets:
' GroupSheets "Sheet1,Sheet3", False
' To group all sheets in a workbook pass an empty string:
' GroupSheets "", False
' You can pass the Wkb arg to specify any open workbook.
' (The Wkb doesn't need to be active for this purpose)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub GroupSheets(Sheetnames As String, _
Optional bInGroup As Boolean = True, _
Optional Wkb As Workbook)
' Groups sheets in Wkb based on whether Sheetnames
' are to be included or excluded in the grouping.
' Arg1 is a comma delimited string. (ie: "Sheet1,Sheet3")
Dim Shts() As String, sz As String
Dim i As Integer, Wks As Worksheet, bNameIsIn As Boolean
If Wkb Is Nothing Then Set Wkb = ActiveWorkbook
For Each Wks In Wkb.Worksheets
bNameIsIn = (InStr(Sheetnames, Wks.Name) > 0)
If bInGroup Then
If bNameIsIn Then sz = Wks.Name
Else
If bNameIsIn Then sz = "" Else sz = Wks.Name
End If
If Not sz = "" Then '//build the array
ReDim Preserve Shts(0 To i): Shts(i) = sz: i = i + 1
End If
Next
Wkb.Worksheets(Shts).Select
End Sub 'GroupSheets
