Macro to sum values from various workbooks if they exist

[samchox]

Hi,

Im trying to come up with a Macro that will perform a =SUM() function across multiple workbooks. Some of these workbooks may exist, some may not.

For example, Summary.xls has a =sum() formula that picks up data from wbk1.xls
wbk2.xls
wbk3.xls
etc, all the way to 100

Today i only have wbk 1, 2 and 3 but i know everyday more wbk's are added so i want to create a sum type function to accomodate the sbk's that may be created at a future time.

Right now when i try it, I not only get REF/# but on opening Summary.xls I get a popup that asks me to define the missing wbk's

Any suggestions?

 

[Richie(UK)]

Hi Sam,

You have two (macro) options as I see it:

1. List all of the workbooks that do exist in a column and then use your macro to loop through each cell in the range.

2. Save all of the workbooks in the same directory and then loop through all of the workbooks in that directory.

Number 2 might look something like this:

Sub OpenAndProcess()
    Dim vaFileName As Variant, wbkData As Workbook, dMySum As Double
    Const MyDir As String = "C:\My Documents\Test"
    'the location of the workbooks
    
    With Application.FileSearch
        .NewSearch
        .LookIn = MyDir
        'the directory to search in
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then
        'workbooks found
            Application.ScreenUpdating = False
            For Each vaFileName In .FoundFiles
            'loop through each found workbook
                Set wbkData = Workbooks.Open(FileName:=vaFileName)
                'open the workbook
                With wbkData
                    With .Worksheets("Sheet1").Range("A1")
                        If IsNumeric(.Value) Then dMySum = dMySum + .Value
                        'add the desired value
                    End With
                    .Close savechanges:=False
                    'close without saving
                End With
            Next vaFileName
            Application.ScreenUpdating = True
            MsgBox "The total is : " & dMySum
        Else
            MsgBox "There were no Excel files found."
        End If
    End With

End Sub

HTH

 

[samchox]

Thank you Richie!

Instead of a Messagebox with dMySum, can I have dMySum, pasted on a particular cell Summary.xls

Thanx

 

[Richie(UK)]

Thank you Richie!

Instead of a Messagebox with dMySum, can I have dMySum, pasted on a particular cell Summary.xls

Thanx

You're welcome :wink:

Just delete the messagebox line and replace it with something like:

ThisWorkbook.Worksheets("Sheet1").Range("A1").Value = dMySum

ThisWorkbook refers to the workbook containing the routine (which I assume is Summary.xls). Just change the Sheet1 and A1 parts to reflect the worksheet and cell that you want to contain the value.

HTH

 

[samchox]

Im back with another couple of questions...

I need to sum cella A20:C45 on each of the wbk.xls files and these are to be pasted in cells A20:C45 on Summary.xls

Also, is there a way to enable macros by default on file open, so that users dont have to click on enable/disable macros

Thanks

 

[samchox]

I tried copying the above macro and changing the cell range each time so i had some 20 odd macros running one after the other to sum data from the different cells i wanted, but that takes forever, since i have almost 140 files to sift through.

Thanks for helping with this
sam

 

[samchox]

Please help!

My reports are stuck for this one problem.

Sam

 

[Richie(UK)]

Hi Sam,

OK, this has received limited testing. See if it helps get you started.

Sub OpenAndProcess()
    Dim vaFileName As Variant, wbkData As Workbook
    Dim vaDataTotal As Variant, vaDataWbk As Variant, lRow As Long, lCol As Long
    Const MyDir As String = "C:\My Documents\Test"
    'the location of the workbooks
    
    With Application.FileSearch
        .NewSearch
        .LookIn = MyDir
        'the directory to search in
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then
        'workbooks found
            Application.ScreenUpdating = False
            ReDim vaDataTotal(1 To 26, 1 To 3) As Variant
            For Each vaFileName In .FoundFiles
            'loop through each found workbook
                Set wbkData = Workbooks.Open(FileName:=vaFileName)
                'open the workbook
                With wbkData
                    vaDataWbk = .Worksheets("Sheet1").Range("A20:C45").Value
                    'get range data into variant (array)
                    For lCol = 1 To 3
                        For lRow = 1 To 26
                            vaDataTotal(lRow, lCol) = _
                                vaDataTotal(lRow, lCol) + vaDataWbk(lRow, lCol)
                        Next lRow
                    Next lCol
                    'add current array values to total array values
                    .Close savechanges:=False
                    'close without saving
                End With
            Next vaFileName
            ThisWorkbook.Worksheets("Sheet1").Range("A20:C45").Value = vaDataTotal
            Application.ScreenUpdating = True
        Else
            MsgBox "There were no Excel files found."
        End If
    End With

End Sub

HTH

 

[samchox]

This was perfect!

Can I get the wbk's to open in read only cause some of them may be in use when this mcaro is run.

Thanks again for your valuable help.
ray:


Sam

 

[Richie(UK)]

Hi Sam,

Have a look at the Workbooks.Open method in the Help files. You will see that there is a ReadOnly parameter - set this to True to open the workbook as ReadOnly.

For example:

Sub Test()
    Workbooks.Open FileName:="ABook.xls", ReadOnly:=True
End Sub

Just amend the relevant line in the code shown above.

HTH