Private Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, sht As Worksheet
'On Error GoTo erfix
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Application.ScreenUpdating = False
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open FileName:=FileNm
For Each sht In Workbooks(FileNm.Name).Worksheets
If sht.Name = "AandB" Then
Workbooks(FileNm.Name).Sheets("AandB").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Exit For
End If
Next sht
Application.DisplayAlerts = False
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub