Here is the code uploaded by Ravashanker. It is going in the right direction and does collect the list of files in the folder.
However when the macro nigel() is run it goes through the first filemane in the list -opens - closes - but then it adds the fault file which is created by macro2() to A1 and "c:\" to B1.
It then rolls to next file in list "EJECTORS" but gives an error filename not found. I assume that it is now searching in C:\ instead of the folder.
Ravs code including my macro 2()
Attached file in which macro works in one workbook
Sub openfiles()
x = Cells(Rows.Count, 1).End(xlUp).Row
For a = 1 To x
Next a
End Sub
Sub nigel()
Dim e As Long, m As Long
Dim f As String, d As String
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
Workbooks("nigel.xls").Sheets("Sheet1").Cells(1, 1) = "=cell(""filename"")"
Workbooks("nigel.xls").Sheets("Sheet1").Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Workbooks("nigel.xls").Sheets("Sheet1").Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.xls")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
Loop
For e = 2 To Cells(Rows.Count, 1).End(xlUp).Row
d = Workbooks("nigel.xls").Sheets("Sheet1").Cells(e, 1)
If Workbooks("nigel.xls").Sheets("Sheet1").Cells(e, 1) <> ActiveWorkbook.Name Then
MsgBox "Opening file " & d
Workbooks.Open Filename:=Workbooks("nigel.xls").Sheets("Sheet1").Cells(1, 2) & d
Call Macro2
ActiveWorkbook.Close False
End If
Next e
ActiveWorkbook.Save
Application.ScreenUpdating = True
MsgBox "All files were updated"
End Sub
Sub Macro2()
Application.ScreenUpdating = False
Dim newWb As Workbook
Dim wbAdded As Boolean
wbAdded = False
For Each sh In ThisWorkbook.Sheets
If Not LCase(sh.Name) Like "control sh*" Then
If Not IsEmpty(sh.Range("R2")) Then
If Not wbAdded Then
wbAdded = True
Set newWb = Workbooks.Add
outRow = 1
End If
sh.Range("A1:c2").Copy
newWb.Sheets(1).Cells(outRow, "a").PasteSpecial Paste:=xlPasteValues
newWb.Sheets(1).Cells(outRow, "a").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
outRow = outRow + 2
shLastRow = sh.Cells(Rows.Count, "r").End(xlUp).Row
sh.Range("P2:R" & shLastRow).Copy newWb.Sheets(1).Cells(outRow, "a")
outRow = outRow + shLastRow
End If
End If
Next
ActiveWorkbook.SaveAs Filename:="C:\FAULT REPORT" & Format(Date, "dd-mm-yyyy") & Format(Time, "hh.mm") & ".xls"
Columns("C:C").ColumnWidth = 12
Application.ScreenUpdating = True
End Sub
There are only 8 workbooks in a folder containing 20 which are to be involved in this loop. If macro can thereby operate from a fixed list in seperate location it would be preferable.
I am struggling with this and any help appreciated.
Bookmarks