Why doesnt it change sheet in the macro
 

Hi,
I have a macro (below) that should loop through a catalog and for
every file copy and paste each sheet. But it only takes one of four
sheets and copies that four times. I have tried all options but are
stuck. All help are appreciated.
Why doesnt it change sheet?

Thanks in advance


Sub create_database()
'
' create_database Macro
' Macro recorded 24/04/2007 by
'

'
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.EnableEvents = True

On Error Resume Next

Set wbCodeBook = ThisWorkbook

With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "\\Expense planning"
.FileType = msoFileTypeExcelWorkbooks
.Filename = "*.xls"

Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
"\\Expense planning\database\database_budget.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Workbooks.Open Filename:= _
"\\Expense planning\3. 44001 Group Marine 2007.xls", _
UpdateLinks:=0

' First sheet to copy header from
Windows("3. 44001 Group Marine 2007_database.xls").Activate
Sheets("US").Select
' Select the area to copy header
Range("A5:T5").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Paste header
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("3. 44001 Group Marine 2007_database.xls").Close
SaveChanges:=False

' ////////////////////////////////////////////////////////////////////////////////////////////////////////
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)



' ///////////////////////////////////////////////////////////////////////////////////////////////////////
' Activate first sheet to copy budget from
' Windows(wbResults).Activate
' ActiveWorkbook.Select
' ActiveWorksheet.Select
' Sheet.Select
' Sheets("US").Select
Worksheets("US").Select

Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheets tab
' Activate first sheet to copy budget from

' Windows(wbResults).Activate
' Sheets.Select
' Sheets("Bda").Select
Worksheets("Bda").Select
Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheet
' Activate first sheet to copy budget from

' Windows(wbResults).Activate
Sheets("5").Select
Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheet
' Activate first sheet to copy budget from

' Windows(wbResults).Activate
Sheets("6").Select
Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheet
wbResults.Close SaveChanges:=True

Next lCount
End If
End With

On Error GoTo 0
' Save the Database
Windows("database_budget.xls").Activate
ActiveWorkbook.Save

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Why doesnt it change sheet in the macro
 

You can loop through worksheets in an Excel workbook with the below code.

Sub LoopWorksheets()
Dim WB As Workbook, WS As Worksheet
Set WB = ThisWorkbook
For Each WS In WB.Worksheets
'Do stuff
Next WS
End Sub

" wrote:

Hi,
I have a macro (below) that should loop through a catalog and for
every file copy and paste each sheet. But it only takes one of four
sheets and copies that four times. I have tried all options but are
stuck. All help are appreciated.
Why doesnt it change sheet?

Thanks in advance


Sub create_database()
'
' create_database Macro
' Macro recorded 24/04/2007 by
'

'
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.EnableEvents = True

On Error Resume Next

Set wbCodeBook = ThisWorkbook

With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "\\Expense planning"
.FileType = msoFileTypeExcelWorkbooks
.Filename = "*.xls"

Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
"\\Expense planning\database\database_budget.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Workbooks.Open Filename:= _
"\\Expense planning\3. 44001 Group Marine 2007.xls", _
UpdateLinks:=0

' First sheet to copy header from
Windows("3. 44001 Group Marine 2007_database.xls").Activate
Sheets("US").Select
' Select the area to copy header
Range("A5:T5").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Paste header
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("3. 44001 Group Marine 2007_database.xls").Close
SaveChanges:=False

' ////////////////////////////////////////////////////////////////////////////////////////////////////////
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)



' ///////////////////////////////////////////////////////////////////////////////////////////////////////
' Activate first sheet to copy budget from
' Windows(wbResults).Activate
' ActiveWorkbook.Select
' ActiveWorksheet.Select
' Sheet.Select
' Sheets("US").Select
Worksheets("US").Select

Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheets tab
' Activate first sheet to copy budget from

' Windows(wbResults).Activate
' Sheets.Select
' Sheets("Bda").Select
Worksheets("Bda").Select
Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheet
' Activate first sheet to copy budget from

' Windows(wbResults).Activate
Sheets("5").Select
Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheet
' Activate first sheet to copy budget from

' Windows(wbResults).Activate
Sheets("6").Select
Range("A6:T140").Select
Selection.Copy
' Switch to database to paste
Windows("database_budget.xls").Activate
' Move to the last cell
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1,
0).Select
' Paste content
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' End copy first sheet
wbResults.Close SaveChanges:=True

Next lCount
End If
End With

On Error GoTo 0
' Save the Database
Windows("database_budget.xls").Activate
ActiveWorkbook.Save

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub