Create Summary WB

[GregR]

I have the following code which works, but believe it can be simplified
and don't know how. Any help appreciated. TIA

Sub CopyReconsChela()
Dim Wb1 As Workbook
Dim Wb2 As Workbook

Application.EnableEvents = False
Application.DisplayAlerts = False

ChDir "G:\IS\ISFinancials\Greg\Project Recons\Active\05_314 Endeca
Search"
Workbooks.Open Filename:= _
"G:\IS\ISFinancials\Greg\Project Recons\Active\05_314 Endeca
Search\Project 05_314 Rev 4_24_06.xls"
Set Wb1 = ActiveWorkbook
Sheets(1).Copy

Set Wb2 = ActiveWorkbook
Wb1.Activate
Wb1.Close

ChDir _
"G:\IS\ISFinancials\Greg\Project Recons\Active\06_032 Internet
Production"
Workbooks.Open Filename:= _
"G:\IS\ISFinancials\Greg\Project Recons\Active\06_032 Internet
Production\Project 06_032 Rev 4_24_06.xls"
Set Wb1 = ActiveWorkbook
Sheets(1).Copy After:=Wb2.Sheets(Wb2.Sheets.Count)
Wb1.Activate
Wb1.Close

ChDir "G:\IS\ISFinancials\Greg\Project Recons\Active\06_012
Internet Staging"
Workbooks.Open Filename:= _
"G:\IS\ISFinancials\Greg\Project Recons\Active\06_012 Internet
Staging\Project 06_012 Rev 4_24_06.xls"
Set Wb1 = ActiveWorkbook
Sheets(1).Copy After:=Wb2.Sheets(Wb2.Sheets.Count)
Wb1.Activate
Wb1.Close

ChDir "G:\IS\ISFinancials\Greg\Project Recons\Active\06_013
Internet CISP"
Workbooks.Open Filename:= _
"G:\IS\ISFinancials\Greg\Project Recons\Active\06_013 Internet
CISP\Project 06_013 Rev 4_24_06.xls"
Set Wb1 = ActiveWorkbook
Sheets(1).Copy After:=Wb2.Sheets(Wb2.Sheets.Count)
Wb1.Activate
Wb1.Close

ActiveWorkbook.SaveAs "C:\Documents and Settings\GregR\My
Documents\Cap Projects\Recons_Chela.xls"

Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

Greg

 

[Guest]

Sub CopyReconsChela()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim s as String
Dim v as Variant
Dim i as Long

v = Array("\05_314 Endeca Search\Project 05_314 Rev 4_24_06.xls", _
"\06_032 Internet Production\Project 06_032 Rev 4_24_06.xls", _
"\06_012 Internet Staging\Project 06_012 Rev 4_24_06.xls", _
"\06_013 Internet CISP\Project 06_013 Rev 4_24_06.xls", _

Application.EnableEvents = False
Application.DisplayAlerts = False

s ="G:\IS\ISFinancials\Greg\Project Recons\Active"

Set Wb1 = Workbooks.Open(Filename:= s & v(lbound(v))
wb1.Sheets(1).Copy

Set Wb2 = ActiveWorkbook
Wb1.Close SaveChanges:=False


for i = lbound(v) + 1 to ubound(v)
Set wb1 = Workbooks.Open( Filename:= s & v(i))
wb1.Sheets(1).Copy After:=Wb2.Sheets(Wb2.Sheets.Count)
Wb1.Close SaveChanges:=False
Next i




ActiveWorkbook.SaveAs "C:\Documents and Settings" & _
"\GregR\My Documents\Cap Projects\Recons_Chela.xls"

Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

check spelling of the strings - especially embedded spaces.

 

[GregR]

Tom, the difference in a pro writing the code and an amateur trying to
get to the show. Thanks

Greg