steveandliss
11-24-2013, 11:29 PM
I need help correcting this code as it is throwing an error at Application.FileSearch and I do not have the experience/knowledge to apply the work arounds posted.
I am using this to selct 4 cells from many sheets in the same folder to combine into a single (new) workbook
Sub make_a_master()
Dim i As Integer
Dim strPath As String
Dim wb As Workbook
Dim NewWb As Workbook
Dim NewR As Range
Dim NewR1 As Range
Dim SavePath As String
strPath = "C:\Users" 'Change this to path of folder with files
SavePath = "C:\Users\Combined.xls" 'Change this to the path and filename you want the
'new workbook to be saved as
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
NewWb.Sheets(1).Name = "Master"
Set NewR = NewWb.Sheets(1).Range("A1")
Set NewR1 = NewWb.Sheets(1).Range("B1")
NewWb.Sheets(1).Select
If ActiveSheet.Cells(1, 1) = "" Then
Range("A1").Select
ActiveCell.FormulaR1C1 = "name"
Columns("A:A").ColumnWidth = 23.43
Range("b1").Select
ActiveCell.FormulaR1C1 = "address"
Columns("B:B").ColumnWidth = 17.43
Range("c1").Select
ActiveCell.FormulaR1C1 = "city, prov"
Columns("c:c").ColumnWidth = 23.43
Range("d1").Select
ActiveCell.FormulaR1C1 = "zip"
Columns("d:d").ColumnWidth = 17.43
Range("A1:d1").Select
Selection.Font.Bold = True
Selection.Font.ColorIndex = 5
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Font
.Name = "MS Reference Sans Serif"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
End If
With Application.FileSearch
.LookIn = strPath
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Set wb = Workbooks.Open(.FoundFiles(i), False)
wb.Sheets("AWF").Range("B2").Copy
Set NewR = NewWb.Sheets(1).Range("A" & NewWb.Sheets(1).Cells.Rows.Count).End(xlUp).Offset(1, 0)
NewR.PasteSpecial xlPasteValues
wb.Sheets("Calculations").Range("Q1").End(xlDown).Copy
Set NewR1 = NewWb.Sheets(1).Range("B" & NewWb.Sheets(1).Cells.Rows.Count).End(xlUp).Offset(1, 0)
NewR1.PasteSpecial xlPasteValues
wb.Close False
Next i
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
NewWb.SaveAs SavePath
Set NewWb = Nothing
Set wb = Nothing
Set NewR = Nothing
Set NewR1 = Nothing
End Sub
I am using this to selct 4 cells from many sheets in the same folder to combine into a single (new) workbook
Sub make_a_master()
Dim i As Integer
Dim strPath As String
Dim wb As Workbook
Dim NewWb As Workbook
Dim NewR As Range
Dim NewR1 As Range
Dim SavePath As String
strPath = "C:\Users" 'Change this to path of folder with files
SavePath = "C:\Users\Combined.xls" 'Change this to the path and filename you want the
'new workbook to be saved as
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
NewWb.Sheets(1).Name = "Master"
Set NewR = NewWb.Sheets(1).Range("A1")
Set NewR1 = NewWb.Sheets(1).Range("B1")
NewWb.Sheets(1).Select
If ActiveSheet.Cells(1, 1) = "" Then
Range("A1").Select
ActiveCell.FormulaR1C1 = "name"
Columns("A:A").ColumnWidth = 23.43
Range("b1").Select
ActiveCell.FormulaR1C1 = "address"
Columns("B:B").ColumnWidth = 17.43
Range("c1").Select
ActiveCell.FormulaR1C1 = "city, prov"
Columns("c:c").ColumnWidth = 23.43
Range("d1").Select
ActiveCell.FormulaR1C1 = "zip"
Columns("d:d").ColumnWidth = 17.43
Range("A1:d1").Select
Selection.Font.Bold = True
Selection.Font.ColorIndex = 5
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Font
.Name = "MS Reference Sans Serif"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
End If
With Application.FileSearch
.LookIn = strPath
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Set wb = Workbooks.Open(.FoundFiles(i), False)
wb.Sheets("AWF").Range("B2").Copy
Set NewR = NewWb.Sheets(1).Range("A" & NewWb.Sheets(1).Cells.Rows.Count).End(xlUp).Offset(1, 0)
NewR.PasteSpecial xlPasteValues
wb.Sheets("Calculations").Range("Q1").End(xlDown).Copy
Set NewR1 = NewWb.Sheets(1).Range("B" & NewWb.Sheets(1).Cells.Rows.Count).End(xlUp).Offset(1, 0)
NewR1.PasteSpecial xlPasteValues
wb.Close False
Next i
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
NewWb.SaveAs SavePath
Set NewWb = Nothing
Set wb = Nothing
Set NewR = Nothing
Set NewR1 = Nothing
End Sub