Hi,

After several attempts to work around but fails to run the complete
codes
Thus, I need help to join the 2nd part of vba codes below so that I
can make the changes in each sheet("P+L") of every workbook in J
folder, thereafter make the defined data range in each sheet of every
workbook in that J folder for data consolidation purpose : -

Sub Totals()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Const MAXBOOK As Long = 4
Dim i%, SheetArg$()
Dim sPath1 As String
ReDim SheetArg(1 To MAXBOOK)
Dim x As String
Dim Namerng As Variant, NameList As Variant

Dim sPath As String, sFile As String
Windows("Budget Consol.xls").Activate
sPath = "J:\BBT\LO\Budget\Budget Actual\Acad2\"
i = 0
sPath1 = "J:\BBT\LO\Budget\Budget Actual\Acad2\*.xls"
sFile = Dir(sPath1)

---------2nd part of join codes ---------------

Dim i As Long
Dim Lstrow As Long
Lstrow = Cells(Rows.Count, "A").End(xlUp).Row
If Lstrow 0 Then
For i = 5 To Lstrow
If Cells(i, 1).Value < "" Then
Cells(i, 1).Copy
Cells(i, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Cells(i, 1).ClearContents
End If
Next
Else
MsgBox "It appears that the file is empty, check the file again"
Exit Sub
End If
----------- End 2nd part -----------------------

Do While sFile < ""
i = i + 1
SheetArg(i) = "'" & sPath & _
[ & sFile & "]P+L'!R6C2:R47C15 "
sFile = Dir()
Loop

ThisWorkbook.Sheets("Sheet2").Range("A1").Consolid ate _
Sources:=Array(SheetArg), Function:=xlSum, TopRow:=True, _
LeftColumn:=True, CreateLinks:=True

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Your help will be much appreciated as I'm vba beginner and thanks in
advance

Regards
Len

It would be easier if you were not using the implicit ActiveSheet and
using Selects, but that said, you can use code like


Dim WB As Workbook
dim WBName As String
Dim WhatFolder As String
WhatFolder = "C:\Your\Folder\Name"
ChDrive WhatFolder
ChDir WhatFolder
WBName = Dir("*.xls",vbNormal)
Do Until WBName = vbNullString
Set WB = Workbooks.Open(WBName)
WB.Worskheets("The Sheet Name").Select
' your code here
WB.Close SaveChanges:=True
WBName= Dir()
Loop

This will loop through every file in the WhatFolder directory, open
that workbook, and activate the desired worksheet. Then your code can
run without further modification. After your code runs, the workbook
is closed, saving the changes.

Cordially,
Chip Pearson
Microsoft MVP 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
[email on web site]





On Sat, 30 Jan 2010 09:50:58 -0800 (PST), Len
wrote:

Hi,

After several attempts to work around but fails to run the complete
codes
Thus, I need help to join the 2nd part of vba codes below so that I
can make the changes in each sheet("P+L") of every workbook in J
folder, thereafter make the defined data range in each sheet of every
workbook in that J folder for data consolidation purpose : -

Sub Totals()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Const MAXBOOK As Long = 4
Dim i%, SheetArg$()
Dim sPath1 As String
ReDim SheetArg(1 To MAXBOOK)
Dim x As String
Dim Namerng As Variant, NameList As Variant

Dim sPath As String, sFile As String
Windows("Budget Consol.xls").Activate
sPath = "J:\BBT\LO\Budget\Budget Actual\Acad2\"
i = 0
sPath1 = "J:\BBT\LO\Budget\Budget Actual\Acad2\*.xls"
sFile = Dir(sPath1)

---------2nd part of join codes ---------------

Dim i As Long
Dim Lstrow As Long
Lstrow = Cells(Rows.Count, "A").End(xlUp).Row
If Lstrow 0 Then
For i = 5 To Lstrow
If Cells(i, 1).Value < "" Then
Cells(i, 1).Copy
Cells(i, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Cells(i, 1).ClearContents
End If
Next
Else
MsgBox "It appears that the file is empty, check the file again"
Exit Sub
End If
----------- End 2nd part -----------------------

Do While sFile < ""
i = i + 1
SheetArg(i) = "'" & sPath & _
[ & sFile & "]P+L'!R6C2:R47C15 "
sFile = Dir()
Loop

ThisWorkbook.Sheets("Sheet2").Range("A1").Consoli date _
Sources:=Array(SheetArg), Function:=xlSum, TopRow:=True, _
LeftColumn:=True, CreateLinks:=True

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Your help will be much appreciated as I'm vba beginner and thanks in
advance

Regards
Len

Hi Chip,

Thanks for your codes and it works fine independently
However, if I were to incorporate and modify your codes to run data
consolidation,
it fails and stops at mid line of codes with run time error "
Subscript out of range "
as indicated below

Sub Totals()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Const MAXBOOK As Long = 4
Dim i%, SheetArg$()
Dim sPath1 As String
ReDim SheetArg(1 To MAXBOOK)

Dim sPath As String, sFile As String
Windows("Budget Consol.xls").Activate
ThisWorkbook.Worksheets("Sheet2").Cells.ClearConte nts
sPath = "M:\Help\LO\Budget\Budget Actual\Academic3\"
i = 0
sPath1 = "M:\Help\LO\Budget\Budget Actual\Academic3\*.xls"
sFile = Dir(sPath1, vbNormal)

Do While sFile < ""
i = i + 1
Dim WB As Workbook
ChDir "M:\Help\LO\Budget\Budget Actual\Academic3"
Set WB = Workbooks.Open(sFile)
WB.Worksheets("P+L").Select
Dim k As Long
Dim Lstrow As Long
Lstrow = Cells(Rows.Count, "A").End(xlUp).Row
If Lstrow 0 Then
For k = 5 To Lstrow
If Cells(k, 1).Value < "" Then
Cells(k, 1).Copy
Cells(k, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End If
Next
Else
MsgBox "It appears that the file is empty, check the file again"
Exit Sub
End If
WB.Close SaveChanges:=True
------------------- xxxxx Run Time Error
xxxxxxxxx---------------------------
SheetArg(i) = "'" & sPath & "[" & sFile & "]P+L'!R6C2:R47C15 "
sFile = Dir()
Loop

ThisWorkbook.Sheets("Sheet2").Range("A1").Consolid ate _
Sources:=Array(SheetArg), Function:=xlSum, TopRow:=True, _
LeftColumn:=True, CreateLinks:=True

Please help up as I still unable to rectify it after debug the error

Thanks & Regards
Len