Thread: Code to open a workbook, do what i want, close it, and open the next

Hi to all. I have many inspection sheets which i need to open, gather the data from, close and open the next one.

I know this is common and ive tried several things here but i dont understand enough to customise existing codes to suit me - here is what i have so far.

Sub Import1()
'
' Import1 Macro
'

'
Workbooks.Open Filename:="S:\01 Files\04 - Work\macro experiment\source data\CS - 003793 - ZS1V57A Valve.xls"
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("A:A") = 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
Workbooks("CS - 003793 - ZS1V57A Valve.xls").Close
ActiveWorkbook.names("Checks").Delete
ActiveWorkbook.names("Conditions").Delete
ActiveWorkbook.names("Date").Delete
ActiveWorkbook.names("dESCRIPTION").Delete
ActiveWorkbook.names("EW").Delete
ActiveWorkbook.names("Ex").Delete
ActiveWorkbook.names("Further").Delete
ActiveWorkbook.names("Gas").Delete
ActiveWorkbook.names("H").Delete
ActiveWorkbook.names("IP").Delete
ActiveWorkbook.names("NS").Delete
ActiveWorkbook.names("Route").Delete
ActiveWorkbook.names("Sensitivity").Delete
ActiveWorkbook.names("Temp").Delete
End Sub

that does everything i want, except i cannot work out how to change:
"Workbooks.Open Filename" to
"Open the first xls file in a fixed defined directory, and do the next bit"

(The next bit works - happy)

And:
"Workbooks("CS - 003793 - ZS1V57A Valve.xls").Close" to
"Close the xls or file you have just done things with, go back and open the next xls file in the folder"

And:
"Do this task until you have opened all the files in the folder then finish"


Ive been able to do all the first bit this evening having never done a macro before from just this forum so im thinking this is the best place for help!

Many thanks,
Stuart

I think this should work

Sub Import1()
Dim fs As Object, Ordner As Object, f1 As Object, fc As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set Ordner = fs.GetFolder(ActiveWorkbook.Path)
Set fc = Ordner.Files
For Each f1 In fc
f1.open
...
f1.close
Next
End Sub

I'm afraid I've no idea what that means and how I go about doing something about it.
Ive been doing this for less than 24 hours!

Thanks,
Stuart

Just to give some more background on this, i have put 4 of the check sheets and the tabulation sheet in a zip file and attached here.

The file FA Tabulation contains the macro and the 4 files which start "CS - " are the source data which is to be imported.

What the completed macro will be presented is a folder with approx 1200 of these sheets, all of which should be processed.

These 1200 sheets can be in the same folder as the "FA Tabulation" file or any other defined folder - it doesn't matter.

You will see the macro does the copy from the check sheet, and paste in to the "Input" sheet. The "gathering" sheet just gathers the data i need from the Input sheet and displays it on a row.

The macro now copies this row and pastes it on a new empty line in the "Table" tab.
Finally, the macro removes any named lists which came over from the check sheet.

This process should repeat until all sheets are imported.

Stuart

put the path-name in a variable and try this:

strPath = ActiveWorkbook.Path & "\" & f1.Name
Workbooks.Open strPfad

Hi,

Thanks for that, it was still not working - it may be a windows 7 thing as i got it to work on a windows xp machine. Its not a problem now, i found a code online which works quite well. Full code i now use is as follows:

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 = "C:\Documents and Settings\S.Graham\Desktop\New Folder\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("Checks").Delete
ActiveWorkbook.names("Conditions").Delete
ActiveWorkbook.names("Date").Delete
ActiveWorkbook.names("dESCRIPTION").Delete
ActiveWorkbook.names("EW").Delete
ActiveWorkbook.names("Ex").Delete
ActiveWorkbook.names("Further").Delete
ActiveWorkbook.names("Gas").Delete
ActiveWorkbook.names("H").Delete
ActiveWorkbook.names("IP").Delete
ActiveWorkbook.names("NS").Delete
ActiveWorkbook.names("Route").Delete
ActiveWorkbook.names("Sensitivity").Delete
ActiveWorkbook.names("Temp").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

Thanks to everybody for the help & advice,

Stuart