Hello,
Have had a very reliable macro i made up a few years ago which copied and the contents from several 1000 excel forms stored in a "Source" folder, and pasted the data into the correct format in a sheet for later importing into a database. One at a time obviously.
My old code is as follows (from http://www.ozgrid.com/VBA/loop-through.htm) :
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "D:\source"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
Range("A2:L67").Select
Range("L67").Activate
Selection.Copy
Windows("Tabulation.xls").Activate
Sheets("Input").Select
Range("A2:L67").Select
Range("L67").Activate
ActiveSheet.Paste
Sheets("Gathering").Select
ActiveWindow.WindowState = xlMaximized
Range("C3:AD3").Select
Range("AD3").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Table").Select
If Application.WorksheetFunction.CountA(ActiveCell.EntireRow) = 0 Then
[A1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
If Err <> 0 Then
On Error GoTo 0
[A65536].End(xlUp)(2, 1).Select
End If
On Error GoTo 0
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
On Error Resume Next
ActiveWorkbook.names("A").Delete
ActiveWorkbook.names("B").Delete
ActiveWorkbook.names("C").Delete
ActiveWorkbook.names("D").Delete
ActiveWorkbook.names("E").Delete
ActiveWorkbook.names("F").Delete
ActiveWorkbook.names("G").Delete
ActiveWorkbook.names("H").Delete
ActiveWorkbook.names("I").Delete
ActiveWorkbook.names("J").Delete
ActiveWorkbook.names("K").Delete
ActiveWorkbook.names("L").Delete
ActiveWorkbook.names("M").Delete
ActiveWorkbook.names("N").Delete
On Error GoTo 0
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I get an error at the wbResults.Close SaveChanges:=False line. I believe this is a result of the FileSearch function not being supported.
Have started another version, but it doesn't work... I think the issue is this code wants to open a new worksheet/file as opposed to writing to the data to the file which contains the macro. I cant remove what i think does this without having issues.
proposed code here (from http://www.ozgrid.com/VBA/2007-files...lternative.htm) :
Sub CopySameSheetFrmWbs()
Dim wbOpen As Workbook
Dim wbNew As Workbook
'Change Path
Const strPath As String = "D:\source"
Dim strExtension As String
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
'Change extension
strExtension = Dir("*.xls")
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Excel\TemplateCollation", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
'DO YOUR CODE HERE
Range("A2:L67").Select
Range("L67").Activate
Selection.Copy
Windows("Tabulation.xls").Activate
Sheets("Input").Select
Range("A2:L67").Select
Range("L67").Activate
ActiveSheet.Paste
Sheets("Gathering").Select
ActiveWindow.WindowState = xlMaximized
Range("C3:AD3").Select
Range("AD3").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Table").Select
If Application.WorksheetFunction.CountA(ActiveCell.EntireRow) = 0 Then
[A1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
If Err <> 0 Then
On Error GoTo 0
[A65536].End(xlUp)(2, 1).Select
End If
On Error GoTo 0
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
On Error Resume Next
ActiveWorkbook.names("A").Delete
ActiveWorkbook.names("B").Delete
ActiveWorkbook.names("C").Delete
ActiveWorkbook.names("D").Delete
ActiveWorkbook.names("E").Delete
ActiveWorkbook.names("F").Delete
ActiveWorkbook.names("G").Delete
ActiveWorkbook.names("H").Delete
ActiveWorkbook.names("I").Delete
ActiveWorkbook.names("J").Delete
ActiveWorkbook.names("K").Delete
ActiveWorkbook.names("L").Delete
ActiveWorkbook.names("M").Delete
ActiveWorkbook.names("N").Delete
On Error GoTo 0
wbResults.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Any help would be appreciated.
Thanks,
Stuart
Have had a very reliable macro i made up a few years ago which copied and the contents from several 1000 excel forms stored in a "Source" folder, and pasted the data into the correct format in a sheet for later importing into a database. One at a time obviously.
My old code is as follows (from http://www.ozgrid.com/VBA/loop-through.htm) :
Quote:
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "D:\source"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
Range("A2:L67").Select
Range("L67").Activate
Selection.Copy
Windows("Tabulation.xls").Activate
Sheets("Input").Select
Range("A2:L67").Select
Range("L67").Activate
ActiveSheet.Paste
Sheets("Gathering").Select
ActiveWindow.WindowState = xlMaximized
Range("C3:AD3").Select
Range("AD3").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Table").Select
If Application.WorksheetFunction.CountA(ActiveCell.EntireRow) = 0 Then
[A1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
If Err <> 0 Then
On Error GoTo 0
[A65536].End(xlUp)(2, 1).Select
End If
On Error GoTo 0
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
On Error Resume Next
ActiveWorkbook.names("A").Delete
ActiveWorkbook.names("B").Delete
ActiveWorkbook.names("C").Delete
ActiveWorkbook.names("D").Delete
ActiveWorkbook.names("E").Delete
ActiveWorkbook.names("F").Delete
ActiveWorkbook.names("G").Delete
ActiveWorkbook.names("H").Delete
ActiveWorkbook.names("I").Delete
ActiveWorkbook.names("J").Delete
ActiveWorkbook.names("K").Delete
ActiveWorkbook.names("L").Delete
ActiveWorkbook.names("M").Delete
ActiveWorkbook.names("N").Delete
On Error GoTo 0
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I get an error at the wbResults.Close SaveChanges:=False line. I believe this is a result of the FileSearch function not being supported.
Have started another version, but it doesn't work... I think the issue is this code wants to open a new worksheet/file as opposed to writing to the data to the file which contains the macro. I cant remove what i think does this without having issues.
proposed code here (from http://www.ozgrid.com/VBA/2007-files...lternative.htm) :
Quote:
Sub CopySameSheetFrmWbs()
Dim wbOpen As Workbook
Dim wbNew As Workbook
'Change Path
Const strPath As String = "D:\source"
Dim strExtension As String
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
'Change extension
strExtension = Dir("*.xls")
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Excel\TemplateCollation", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
'DO YOUR CODE HERE
Range("A2:L67").Select
Range("L67").Activate
Selection.Copy
Windows("Tabulation.xls").Activate
Sheets("Input").Select
Range("A2:L67").Select
Range("L67").Activate
ActiveSheet.Paste
Sheets("Gathering").Select
ActiveWindow.WindowState = xlMaximized
Range("C3:AD3").Select
Range("AD3").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Table").Select
If Application.WorksheetFunction.CountA(ActiveCell.EntireRow) = 0 Then
[A1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
If Err <> 0 Then
On Error GoTo 0
[A65536].End(xlUp)(2, 1).Select
End If
On Error GoTo 0
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
On Error Resume Next
ActiveWorkbook.names("A").Delete
ActiveWorkbook.names("B").Delete
ActiveWorkbook.names("C").Delete
ActiveWorkbook.names("D").Delete
ActiveWorkbook.names("E").Delete
ActiveWorkbook.names("F").Delete
ActiveWorkbook.names("G").Delete
ActiveWorkbook.names("H").Delete
ActiveWorkbook.names("I").Delete
ActiveWorkbook.names("J").Delete
ActiveWorkbook.names("K").Delete
ActiveWorkbook.names("L").Delete
ActiveWorkbook.names("M").Delete
ActiveWorkbook.names("N").Delete
On Error GoTo 0
wbResults.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Thanks,
Stuart