PDA

View Full Version : Sleeper: With Application.FileSearch not working in 2010 macro



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

steveandliss
11-25-2013, 05:05 AM
need to remove the [/\b\] and [b]

mancubus
11-25-2013, 06:29 AM
check these links to process all files in a folder: (1) http://www.vbaexpress.com/kb/getarticle.php?kb_id=221 (2)http://www.vbaexpress.com/kb/getarticle.php?kb_id=9

steveandliss
12-08-2013, 09:08 PM
very interesting but my macro trips on the With Application.FileSearch command and I need to fix it.
or
I need a macro that will take 4 fields from 100-200 workbooks in the same folder and consolidates them on to one list

GTO
12-08-2013, 10:50 PM
Greetings and welcome to VBAX :-)

Application.FileSearch was depreciated (a fancy way of saying it's no longer supported and isn't available) in Excel 2007 and thereafter. Did you check out the links Mancubus offered? Both show looping through files in a folder, using Dir(), which still works fine. I would suggest reading the links and the Help topic and having a go at it. If your attempts fail, then post a sample workbook with the code you write.

Hope that helps,

Mark

steveandliss
12-08-2013, 11:58 PM
to simplify what I am trying to do please see the following:

I have 100 invoices which I want to collect the contents of cells A8, A9, A10 and A11 then write them to a single list (new workbook). All 100 invoices have the same naming convention and are saved in the same directory
anyone have a quick vba macro that I could steal?

mancubus
12-09-2013, 01:23 AM
Sub make_a_master()
Dim wb As Workbook, ConsWB As Workbook
Dim fPath As String, fName As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
fPath = "C:\Users"
Set ConsWB = Workbooks.Add
With ActiveSheet
.Name = "Master"
With .Range("A1:D1")
.Value = Array("Name", "Address", "City, Prov", "Zip")
.Font.Bold = True
.Font.ColorIndex = 5
With .Resize(.Rows.Count).Font
.Name = "MS Reference Sans Serif"
.Size = 10
End With
End With
fName = Dir(fPath & "\" & "*.xls*", vbNormal)
Do Until fName = ""
Set wb = Workbooks.Open(Filename:=fPath & "\" & fName)
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(wb.ActiveSheet.Range("A8:A11").Value)
wb.Close False
fName = Dir()
Loop
.Columns.AutoFit
End With
ConsWB.SaveAs "C:\Combined.xls"
'do not save the new file in the same folder with the files to be consolidated.
End Sub

mancubus
12-09-2013, 02:20 PM
corrected :)



Sub make_a_master()

Dim wb As Workbook, ConsWB As Workbook
Dim fPath As String, fName As String

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

fPath = "C:\Users"

Set ConsWB = Workbooks.Add
With ActiveSheet
.Name = "Master"
With .Range("A1:D1")
.Value = Array("Name", "Address", "City, Prov", "Zip")
.Font.Bold = True
.Font.ColorIndex = 5
With .Resize(Rows.Count).Font
.Name = "MS Reference Sans Serif"
.Size = 10
End With
End With

fName = Dir(fPath & "\" & "*.xls*", vbNormal)
Do Until fName = ""
Set wb = Workbooks.Open(Filename:=fPath & "\" & fName)
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(wb.ActiveSheet.Range("A8:A11").Value)
'.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(wb.Sheets("MySheet").Range("A8:A11").Value) 'alternatively you may use this.
wb.Close False
fName = Dir()
Loop
.Columns.AutoFit
End With

ConsWB.SaveAs "C:\Combined.xls" 'donot save the new file in the same folder with the files to be consolidated.

End Sub