Sum a range in all workbooks in a folder

[borisg5]

I am new to VBA and have searched widely for an easy answer to this.
Whilst I have found many elements to solve this, I don't have the
skills to pull it all together. I have studied Ron DeBruins material
with some success.
Here is the problem.....

Each month, I have over 40 workbooks, each with 1 worksheet only (with
different names) in a folder (for that month) on a network. Staff
enter data in columns A to BI. The data is totalled in BJ1:BR35 in
every workbook (these cells are sheet password protected). I would
like a macro to run to:
1. Be able to select the folder and files within it (I am OK with
this part)
2. Consolidate all the workbooks in the selected files for the totals
(ie. sum all the values in BJ1:BJ35 - columns BJ and BP and the
first two rows have text - all other cells have values which need to
be summed) and paste values to a new workbook.
Any help is appreciated.

Thank you
Bob

 

[Barb Reinhardt]

Well, you'd need to do something like this. Note, this is untested

Sub OpenAllXLS()
Dim oWB As Workbook
Dim WS As Worksheet
Dim aWS As Worksheet

aWS.Cells(1, 1).Value = "WOrkbook"
aWS.Cells(1, 2).Value = "Worksheet"
aWS.Cells(1, 3).Value = "BJ1:BJ10 Sum"
aWS.Cells(1, 4).Value = "BP1:BP10 Sum"

ChDir "Data"
currentfile = Dir("*.xls")
Do While currentfile <> ""
Set oWB = Workbooks.Open(Filename:=currentfile)
For Each WS In oWB.Worksheets
Debug.Print WS.Name
Debug.Print mycalc
lrow = aWS.Cells(aWS.Rows.Count, 1).End(xlUp).Row + 1
aWS.Cells(lrow, 1).Value = oWB.Name
aWS.Cells(lrow, 2).Value = WS.Name
aWS.Cells(lrow, 3).Value = Sum(WS.Range("BJ1:BJ10")) 'won't work if
there's text there
aWS.Cells(lrow, 4).Value = Sum(WS.Range("BP1:BP10"))

Next WS

currentfile = Dir
Loop
End Sub

 

[borisg5]

Well, you'd need to  do something like this.  Note, this is untested

Sub OpenAllXLS()
Dim oWB As Workbook
Dim WS As Worksheet
Dim aWS As Worksheet

aWS.Cells(1, 1).Value = "WOrkbook"
aWS.Cells(1, 2).Value = "Worksheet"
aWS.Cells(1, 3).Value = "BJ1:BJ10 Sum"
aWS.Cells(1, 4).Value = "BP1:BP10 Sum"

ChDir "Data"
currentfile = Dir("*.xls")
Do While currentfile <> ""
    Set oWB = Workbooks.Open(Filename:=currentfile)
    For Each WS In oWB.Worksheets
        Debug.Print WS.Name
        Debug.Print mycalc
        lrow = aWS.Cells(aWS.Rows.Count, 1).End(xlUp).Row + 1
        aWS.Cells(lrow, 1).Value = oWB.Name
        aWS.Cells(lrow, 2).Value = WS.Name
        aWS.Cells(lrow, 3).Value = Sum(WS.Range("BJ1:BJ10"))  'won't work if
there's text there
        aWS.Cells(lrow, 4).Value = Sum(WS.Range("BP1:BP10"))

    Next WS

    currentfile = Dir
Loop
End Sub

--
HTH,
Barb Reinhardt







- Show quoted text -

Hi Barb,
Thanks for this, I am getting a Compile Error:Variable not defined
when it gets to Currentfile (line after ch directory)
Regards
Bob

 

[Dave Peterson]

Another one:

Option Explicit
Sub testme01()

Dim RptWks As Worksheet
Dim DestCell As Range
Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim TempWks As Worksheet
Dim myAddr As String

'use whatever you know to get the folder
myPath = "C:\my documents\excel\test\"
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

myAddr = "BJ1:BJ35"

Set RptWks = Workbooks.Add(1).Worksheets(1)
RptWks.Range("A1").Resize(1, 3).Value _
= Array("Workbook Name", "Worksheet Name", "Sum of " & myAddr)
Set DestCell = RptWks.Range("a2")

'get the list of files
fCtr = 0
Do While myFile <> ""
If LCase(myFile) Like LCase("*.xls") Then
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
End If
myFile = Dir()
Loop

If fCtr > 0 Then
For fCtr = LBound(myNames) To UBound(myNames)
Set TempWks = Workbooks.Open _
(Filename:=myPath & myNames(fCtr)).Worksheets(1)
With DestCell
.Value = TempWks.Parent.FullName
.Offset(0, 1).Value = "'" & TempWks.Parent.Name
.Offset(0, 2).Value = Application.Sum(TempWks.Range(myAddr))
End With
Set DestCell = DestCell.Offset(1, 0)
TempWks.Parent.Close savechanges:=False
Next fCtr
End If

RptWks.UsedRange.Columns.AutoFit

End Sub

 

[borisg5]

Another one:

Option Explicit
Sub testme01()

    Dim RptWks As Worksheet
    Dim DestCell As Range
    Dim myNames() As String
    Dim fCtr As Long
    Dim myFile As String
    Dim myPath As String
    Dim TempWks As Worksheet
    Dim myAddr As String

    'use whatever you know to get the folder
    myPath = "C:\my documents\excel\test\"
    If myPath = "" Then Exit Sub
    If Right(myPath, 1) <> "\" Then
        myPath = myPath & "\"
    End If

    myFile = ""
    On Error Resume Next
    myFile = Dir(myPath & "*.xls")
    On Error GoTo 0
    If myFile = "" Then
        MsgBox "no files found"
        Exit Sub
    End If

    myAddr = "BJ1:BJ35"

    Set RptWks = Workbooks.Add(1).Worksheets(1)
    RptWks.Range("A1").Resize(1, 3).Value _
        = Array("Workbook Name", "Worksheet Name", "Sum of " & myAddr)
    Set DestCell = RptWks.Range("a2")

    'get the list of files
    fCtr = 0
    Do While myFile <> ""
        If LCase(myFile) Like LCase("*.xls") Then
             fCtr = fCtr + 1
             ReDim Preserve myNames(1 To fCtr)
             myNames(fCtr) = myFile
        End If
        myFile = Dir()
    Loop

    If fCtr > 0 Then
        For fCtr = LBound(myNames) To UBound(myNames)
            Set TempWks = Workbooks.Open _
                             (Filename:=myPath & myNames(fCtr)).Worksheets(1)
            With DestCell
                .Value = TempWks.Parent.FullName
                .Offset(0, 1).Value = "'" & TempWks.Parent.Name
                .Offset(0, 2).Value = Application.Sum(TempWks.Range(myAddr))
            End With
            Set DestCell = DestCell.Offset(1, 0)
            TempWks.Parent.Close savechanges:=False
        Next fCtr
    End If

    RptWks.UsedRange.Columns.AutoFit

End Sub









--

Dave Peterson- Hide quoted text -

- Show quoted text -

Thanks Dave,
This work brilliantly - although it was not what I had intended. It
is fantastic to sum a column of all worksheets. I will try to be
clearer. I want to consolidate (using sum, each cell in the range of
BJ1:BR35 into a new workbook) I wanted to create a summary sheet that
added each individual cell in the range of BJ1:BR35 (ie. BK3 in the
1st worbook + BK3 in the 2nd workbook + BK3 in the 3rd workbook .....
for all the workbooks in the folder and place that value in a new
summary sheet . Repeat this for BK4, BK5 etc etc (for all cells in
the range of BK1:BR35 - excluding columns BJ and BP as they have
text). I have provided a layout of the BJ1:BR35 range below.


BJ column BK BL
BM BN BO BP
BQ BR
1 SUMMARY - ALL TestONE Apr,2008 SUMMARY - NON INPATIENT OOS
2 Inpatient Outpatient Grand Total
3Total NEW & REV 9 15 24 Registrations 3
4NEW 3 3 6 Non Inpt OOS 12
5REVIEW 6 12 18
6
7Total Indiv. Pts Managed 6
8
9NO. of Groups 3 NO. of Groups 2
10Total # Grp participants 12 Total # Grp participants 11
11
12Goals No.
13Met 0% Goals 0 Compensables
14Met 25% Goals 2 Transcover 0
15Met 50% Goals 1 Motor Vehicles Act 0
16Met 75% Goals 1 Workers Compensation 0
17Met 100% Goals 2
18Total Patients 6 Non Compensables
19 Veteran Affairs 0
20Wait Time Total Days No. Waited Average Wait Days Home visits 1 1
21Ave Calendar Days 6.0 6 1.0 Phone Consultation 1 1
22Ave Week Days 6.0 6 1.0 Privately referred 0
23 Other 0
24Total Time Hours 17
25
26No. Not Seen 0
27
28Seen Within No.
291 hour 3
304 hours 1
318 hours 1
32> 8 hours 1
33Total 6
34
35Total ON Call 4
I hope this gives a clearer picture of what I am trying to achieve.
Thanks
Bob

 

[Dave Peterson]

Maybe...

Option Explicit
Sub testme01()

Dim RptWks As Worksheet
Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim TempWks As Worksheet
Dim myAddr As String
Dim myCell As Range

'use whatever you know to get the folder
myPath = "C:\my documents\excel\test\"
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

myAddr = "BJ1:BR35"

Set RptWks = Workbooks.Add(1).Worksheets(1)

'get the list of files
fCtr = 0
Do While myFile <> ""
If LCase(myFile) Like LCase("*.xls") Then
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
End If
myFile = Dir()
Loop

If fCtr > 0 Then
For fCtr = LBound(myNames) To UBound(myNames)
Set TempWks = Workbooks.Open _
(Filename:=myPath & myNames(fCtr)).Worksheets(1)
For Each myCell In TempWks.Range(myAddr).Cells
If IsNumeric(myCell.Value) Then
With RptWks.Range(myCell.Address)
.Value = .Value + myCell.Value
End With
End If
Next myCell
TempWks.Parent.Close savechanges:=False
Next fCtr
End If

RptWks.UsedRange.Columns.AutoFit

End Sub

It puts the sum in the same location as the range to add. After it's finished,
you can do whatever you want--move it to a nice location or add descriptions.

I couldn't see the layout that you posted. Too many line wraps.