Hi Guys,

Im having trouble extracting data from multiple workbooks into one master workbook I’m working with excel 2000 and all the files in question are located in the same Folder on my desktop.

I can get the data to copy into the master as long as all workbooks are open. (Not what I’m after as it will be pulling in data from 20+ workbooks when the thing is finally up and running)

I found a hack on the net were by code opens each workbook one at a time and then closes is after it has done its thing.

I want to integrate my code with the code I found on the net… as follows


The two pieces of code….

Sub OpenAllWorkbooks2003()
'Open a With structure for the Application object and prepare Excel.
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.AskToUpdateLinks = False
'Declare and define variables
Dim SourcePath As String, iFile As Integer
SourcePath = "C:/Your/File/Path/"
'Open each workbook in the source folder, and do something with it.
With .FileSearch
.LookIn = SourcePath
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
For iFile = 1 To .FoundFiles.Count
Workbooks.Open (.FoundFiles(iFile))
'This is where your actual code would go to do whatever you have in mind with these workbooks.
MsgBox "Workbook that is open now:" & vbCrLf & ActiveWorkbook.Name & vbCrLf & vbCrLf & _
"Your code would go here to do something with these workbooks.", , "Example"
'Save and close the workbook and move on to the next one.
ActiveWorkbook.Close True
Next iFile
Else
'Advise the user if no workbooks exist in the folder.
With Application
.AskToUpdateLinks = True
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox "No such files exist in the path " & SourcePath & ".", , "Nothing to open."
Exit Sub
End If
End With
'Close the With structure for the Application object and reset Excel.
.AskToUpdateLinks = True
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
'Advise the user that the macro is complete
MsgBox "All workbooks in " & SourcePath & vbCrLf & _
"have been opened and closed.", 64, "OK, all done !!"
End Sub



And I need to somehow integrate this into my code which is…..


Sub update()

On Error Resume Next

For pm = 1 To 20
If Sheets("Project Managers").Cells(pm, 1).Value = "" Then Exit Sub

PM_NAME = Sheets("Project Managers").Cells(pm, 1).Value

xlscreenupdating = False
Workbooks.Open (PM_NAME & ".xls"), xlReadOnly



R_PM = 4: exit_do2 = False
Do

EMD = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 2).Value
R_SM = 4: exit_do1 = False
Do
If Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 2).Value = "" Then
exit_do2 = True
Exit Do
End If
If Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 3).Value <> "" _
And Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 2).Value = EMD And _
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 3).Value <> PM_NAME And _
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 2).Value <> "" Then
MsgBox ("Error - Duplicate EMD on line" & " " & R_SM & " on " & PM_NAME & ".xls")
Exit Sub
End If

If Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 2).Value = EMD Then 'find project in summary
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 4).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 4).Value 'if found then paste
Exit Do 'now exit for new
End If

If Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 2).Value = "" Then 'if cannot find then new project
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 2).Value = EMD 'Project ref
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 1).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 1).Value 'project title
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 3).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 3).Value 'project Officer
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 4).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 13).Value 'Project Budget
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 5).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 14).Value 'contractor
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 6).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 15).Value 'Tender Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 13).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 4).Value 'First date
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 14).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 5).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 15).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 6).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 16).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 7).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 17).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 8).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 18).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 9).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 19).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 10).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 20).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 11).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 21).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 12).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 22).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 13).Value
Workbooks("EMD Project Register v1.2b 2010-11.xls").Sheets(2).Cells(R_SM, 23).Value = Workbooks(PM_NAME & ".xls").Sheets(1).Cells(R_PM, 16).Value







Exit Do
End If
R_SM = R_SM + 1
Loop Until exit_do1 = True Or R_SM = 1000 'exit


R_PM = R_PM + 1


Loop Until exit_do2 = True
'Workbooks(PM_NAME & ".xls").Close
Next
xlscreenupdating = True

End Sub

Or if someone can think of an easier way to do this I would be forever in your debt, ha
Thanks and regards

Lee