Results 1 to 10 of 10
  1. #1
    mindbender is offline Competent Performer
    Windows XP Access 2007
    Join Date
    May 2013
    Posts
    283

    Subtotalling multiple workbooks

    Hello,



    The following vba opens each workbook in the temp folder and changes the name of the first column header. I am wondering if it is possible to modify it so instead of change the first column header, it selects all the rows in the worksheet, and subtotals all of the columns after the third column at each change in column 2

    The data I have is phone data so each day of the month the previous day will be added to the worksheet so the range will change every day when it is run.

    I attached a file showing how the data is naturally and how I would like to see it after the update

    I have been looking up range object and subtotal method but I am not getting it at all.

    Thanks as always

    Code:
    Sub Example()
        Dim MyPath As String, FilesInPath As String
        Dim MyFiles() As String, Fnum As Long
        Dim mybook As Workbook
        Dim CalcMode As Long
        Dim sh As Worksheet
        Dim ErrorYes As Boolean
        Dim rng As Range
        Dim cell As Range
        'Fill in the path\folder where the files are
        MyPath = "C:\Temp"
        'Add a slash at the end if the user forget it
        If Right(MyPath, 1) <> "\" Then
            MyPath = MyPath & "\"
        End If
        'If there are no Excel files in the folder exit the sub
        FilesInPath = Dir(MyPath & "*.xl*")
        If FilesInPath = "" Then
            MsgBox "No files found"
            Exit Sub
        End If
        'Fill the array(myFiles)with the list of Excel files in the folder
        Fnum = 0
        Do While FilesInPath <> ""
            Fnum = Fnum + 1
            ReDim Preserve MyFiles(1 To Fnum)
            MyFiles(Fnum) = FilesInPath
            FilesInPath = Dir()
        Loop
        'Change ScreenUpdating, Calculation and EnableEvents
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        'Loop through all files in the array(myFiles)
        If Fnum > 0 Then
            For Fnum = LBound(MyFiles) To UBound(MyFiles)
                Set mybook = Nothing
                On Error Resume Next
                Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
                On Error GoTo 0
                If Not mybook Is Nothing Then
    
                    'Change cell value(s) in one worksheet in mybook
                    On Error Resume Next
                    With mybook.Worksheets(1)
                        If .ProtectContents = False Then
                       ' Set rng = Range("A1").CurrentRegion
                        '
                       ' For Each cell In rng
                       ' If cell.Value Is Null Then cell.Value = 0
                       ' Next cell
                            .Range("A1").Value = "My New Header"
                        Else
                            ErrorYes = True
                        End If
                    End With
    
                    If Err.Number > 0 Then
                        ErrorYes = True
                        Err.Clear
                        'Close mybook without saving
                        mybook.Close savechanges:=False
                    Else
                        'Save and close mybook
                        mybook.Close savechanges:=True
                    End If
                    On Error GoTo 0
                Else
                    'Not possible to open the workbook
                    ErrorYes = True
                End If
            Next Fnum
        End If
        If ErrorYes = True Then
            MsgBox "There are problems in one or more files, possible problem:" _
                 & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
        End If
        'Restore ScreenUpdating, Calculation and EnableEvents
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With
    End Sub
    Green.zip

  2. #2
    aytee111 is offline Competent At Times
    Windows 10 Access 2013 64bit
    Join Date
    Nov 2011
    Location
    Nomad
    Posts
    3,936
    Is the file being created in the database, or are you just updating files that already exist?

  3. #3
    mindbender is offline Competent Performer
    Windows XP Access 2007
    Join Date
    May 2013
    Posts
    283
    Quote Originally Posted by aytee111 View Post
    Is the file being created in the database, or are you just updating files that already exist?
    I am trying to update files that already exist

  4. #4
    aytee111 is offline Competent At Times
    Windows 10 Access 2013 64bit
    Join Date
    Nov 2011
    Location
    Nomad
    Posts
    3,936
    The reason I ask is that the worksheet is called "qry_ExportCopy_Final" which points to it being created in Access. It would be far simpler to export the totals at the same time instead of having to add them afterwards.

    The way I update Excel files is to make the change in Excel, then add that line to the VBA code, one at a time.

  5. #5
    mindbender is offline Competent Performer
    Windows XP Access 2007
    Join Date
    May 2013
    Posts
    283
    I have been messing around with this but I get errors There are problems in one or more files, possible problems: protected workbook/sheet or a sheet/range that not exist

    Code:
                        
    Dim rSubV As Range           ' Columns where the Subtotal calculates values
    Dim vArrCol                       ' array with the column numbers of rSubV
     
     Set rSubV = Range(Cells(4, 64), Cells(1, Columns.Count).End(xlToLeft)) ' I chose 4,64 because the first column I want to subtotal is 4 and the maximum number of columns there could ever be is 64
    vArrCol = Evaluate("column(" & rSubV.Address & ")")
     
    Range("A1").Subtotal GroupBy:=1, Function:=xlSum, _
    TotalList:=vArrCol, SummaryBelowData:=xlSummaryBelow

  6. #6
    mindbender is offline Competent Performer
    Windows XP Access 2007
    Join Date
    May 2013
    Posts
    283
    That would be the ideal solution but I am having no luck getting it to work. I used Allen Browne's method to use multiple values in a crosstab and have been able to get row totals but not column totals.

  7. #7
    aytee111 is offline Competent At Times
    Windows 10 Access 2013 64bit
    Join Date
    Nov 2011
    Location
    Nomad
    Posts
    3,936
    Column totals require a UNION query. Query1 to get the data, query2 to get the totals, query3 to join them in a UNION query, sorting on the second column.

  8. #8
    mindbender is offline Competent Performer
    Windows XP Access 2007
    Join Date
    May 2013
    Posts
    283
    I have the following working. I just need (4,5) to be 4,to the end of all existing columns as this will vary

    Code:
                    
    With mybook.Worksheets(1)
    If .ProtectContents = False Then
                        
     ActiveSheet.Range("1:1").Font.Bold = True
    ActiveSheet.Range("1:1").EntireColumn.AutoFit
                       
     Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5)
                                                  
    Else
    ErrorYes = True
    End If
    End With

  9. #9
    aytee111 is offline Competent At Times
    Windows 10 Access 2013 64bit
    Join Date
    Nov 2011
    Location
    Nomad
    Posts
    3,936
    There are a bunch of different ways here : https://stackoverflow.com/questions/...t-with-a-macro
    All Excel VBA but maybe you can find one that works for you.

  10. #10
    mindbender is offline Competent Performer
    Windows XP Access 2007
    Join Date
    May 2013
    Posts
    283
    Quote Originally Posted by aytee111 View Post
    There are a bunch of different ways here : https://stackoverflow.com/questions/...t-with-a-macro
    All Excel VBA but maybe you can find one that works for you.
    I had no success with those. I am so close. Just need the following code to work in a range to find from column 4 to the last column as the number of columns will vary

    Code:
    With mybook.Worksheets(1)
     If .ProtectContents = False Then
    
     ActiveSheet.Range("1:1").Font.Bold = True
     ActiveSheet.Range("1:1").EntireColumn.AutoFit
    
     Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5)
    
     Else
     ErrorYes = True
     End If
     End With

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 22
    Last Post: 12-29-2015, 10:41 PM
  2. Replies: 1
    Last Post: 01-09-2013, 04:11 PM
  3. Replies: 12
    Last Post: 12-17-2012, 12:47 PM
  4. Importing from multiple spreadhseets across multiple workbooks
    By sgtpsychosis in forum Import/Export Data
    Replies: 2
    Last Post: 06-08-2012, 01:24 PM
  5. Field Subtotalling by Date
    By domingo2615 in forum Access
    Replies: 6
    Last Post: 07-20-2011, 07:26 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums