asked on

Total columns

i have the following code but i do not need to display the group totals only the grand total.

'Store Level History Report
Option Compare Database
Option Explicit
 
' ***********************************************************************
' This module calls the relevant Query and takes the values from the form
' ***********************************************************************
Dim objXLapp As Object
Dim objWB As Object
Dim objWS1 As Object
 
Dim Heading1, Heading2, Heading3, Heading4, Heading5, Heading6, Heading7, Heading8 As String   ' Used for the heading on the excel ouput
Dim Heading9, Heading10, Heading11, Heading12, Heading13, Heading14, Heading15, Heading16 As String
 
Dim RightHeader As String
'Dim RightHeader As String
Dim strSQL As String
 
Dim Tbl1  As String
 
Dim TotalColumn() As Integer
 
Sub GenerateExcelSpreadsheet()
 
Dim Tbl1 As String
 
    DoCmd.Hourglass (True)
    DoCmd.SetWarnings (False)
    
    Dim RecCount As Long
 
    On Error Resume Next
    DoCmd.DeleteObject acTable, "D Branch Raw Data Set"
    DoCmd.DeleteObject acTable, "SalesDpt"
    'SalesDpt
    On Error GoTo 0
 
 
' ********************************************
' * Check to see if the table is populated   *
' ********************************************
    DoCmd.OpenQuery "F Multiple Store History Raw Data maker"
    DoCmd.OpenQuery "FF Dept Qry Maker"
           
    Tbl1 = "FF Dept tbl"
     
    If (DCount("*", "[FF Dept tbl]") = 0) Then
        MsgBox "No records meet this criteria", vbInformation, "Store Dep Sales Period A"
        DoCmd.SetWarnings (True)
        DoCmd.Hourglass (False)
    End    ' If are no records so don't go any further
    End If   ' End of Count check
 
 
' *********************************************************************************
' * Finished Creating Tables, from the queries, depending on the users criteria   *
' *********************************************************************************
    RecCount = DCount("*", "[FF Dept tbl]")
    
    Set objXLapp = CreateObject("Excel.Application")
    
    With objXLapp
        .Visible = False  '                        ' << ---- To see Excel change to True
          '.Workbooks.Open MyDir & "Counts.xls"
        .Workbooks.Add
    End With
 
    Set objWB = objXLapp.ActiveWorkbook
    
    objXLapp.StatusBar = RecCount & " records"
    Set objWS1 = objXLapp.Worksheets(1)
    
    objWS1.Name = "Store Dep Sales Period A"
 
 
' **************************************************************
' From Access Open The Relevant Table and Copy To The Clipboard*
' **************************************************************
      ' Table 1
     DoCmd.SelectObject acTable, (Tbl1), True
     DoCmd.DoMenuItem acFormBar, acEditMenu, acCopy, , acMenuVer70
     DoCmd.Minimize
     'Forms!frmOrderBookQueries.SetFocus
     DoCmd.Maximize
    
     objWS1.Select
     objWS1.Cells(1, 1).Select
     objWS1.Paste
     objXLapp.CutCopyMode = False    ' Empty Clipboard
     
     DoCmd.SetWarnings (True)
     
     With objWS1.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
     End With
          
          
' *************************
' Set the page properites *
' *************************
    With objWS1.PageSetup
    
        '.LeftHeader = "&""Arial,Bold Italic""&16" & Heading1 & " " & Heading2 & " " & Heading3 & " " & Heading4
        
        '.CenterFooter = "&D, Page &P of &N"
        '.RightFooter = ""
                       
        .CenterHeader = "Store Dep Sales Period A"
        .RightHeader = "&D"
        .CenterFooter = "Page &P of &N"
        
        .LeftMargin = objXLapp.InchesToPoints(0.6)
        .RightMargin = objXLapp.InchesToPoints(0.6)
        .TopMargin = objXLapp.InchesToPoints(0.75)
        .BottomMargin = objXLapp.InchesToPoints(0.65)
        .HeaderMargin = objXLapp.InchesToPoints(0.5)
        .FooterMargin = objXLapp.InchesToPoints(0.5)
         
        .Orientation = xlLandscape
        
        'Fit to one page wide ....
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1000
        
    End With
          
    ' Set the column widths and font size...
     objWS1.Cells(1, 1).CurrentRegion.Select
        
     With objWS1.Cells.Font
        .Name = "Arial"
        .Size = 8
        '.Bold = "True"
        '.Width = 10
     End With
          
          
'********************************************************************************
' To work through each column,check the headings and then format each column....
'********************************************************************************
Dim a As Integer
Dim Workfld As String
Dim FldName As String
Dim FldType As String
Dim ColWidth As Integer
Dim NumOfRows As Integer
     
    NumOfRows = objWS1.Cells(1, 1).CurrentRegion.Rows.Count
    
    'Change the row height of the top row...
    objWS1.Rows("1:1").RowHeight = 40
    objWS1.Rows("1:1").Interior.ColorIndex = xlNone
 
    'Change the row height of the rows..
    
    DoCmd.Hourglass (True)
    ' Loop through each column
        For a = 1 To objWS1.Cells(1, 1).CurrentRegion.Columns.Count
    
             Workfld = objWS1.Cells(1, a)
             
             Select Case Workfld   ' Workfld contains the field heading
              '1
                Case "BR"
                    FldName = "BR"
                    FldType = "General"
                    ColWidth = 7
                '2
                Case "Branch"
                    FldName = "Branch"
                    FldType = "General"
                    ColWidth = 25
                '3
                Case "Dept"
                    FldName = "BR"
                    FldType = "General"
                    ColWidth = 3
                '4
                Case "Total £ Sales"
                    FldName = "Total £ Sales"
                    FldType = "Number0"
                    ColWidth = 15
                '5
                 Case "WK"
                    'FldName = "Total £ Sales"
                    FldType = "Number0"
                    ColWidth = 15
                 '6
                 Case "fiscyrpercode"
                    'FldName = "Total £ Sales"
                    FldType = "Number0"
                    ColWidth = 15
 
             Case Else
             
             FldName = Workfld
             FldType = "General"
    
            End Select
                         
            objWS1.Cells(1, a) = FldName ' Change the field name,if required
            
            'Format the columns that are made up from the CT query.
            If (FldName Like "200*") Then
                FldType = "Number0"
            End If
            
            'If (FldName Like "Stk *") Then
                'FldType = "Number0"
            'End If
            
'********************************
'*Change the format of the field*
'********************************
            If (FldType = "General") Then
                objWS1.Columns(a).NumberFormat = "General"
            End If
 
            If (FldType = "Percent") Then
                objWS1.Columns(a).NumberFormat = "0%"
            End If
        
            If (FldType = "Number0") Then
                objWS1.Columns(a).NumberFormat = "£#,##0"
            End If
        
            If (FldType = "Number2") Then
                objWS1.Columns(a).NumberFormat = "#,##0.00"
            End If
        
            If (FldType = "Number3") Then
                objWS1.Columns(a).NumberFormat = "0"
            End If
        
            If (FldType = "Currency") Then
                objWS1.Columns(a).NumberFormat = "£#,###0.00"
            End If
    
            If (FldType = "Currency2") Then
                objWS1.Columns(a).NumberFormat = "£#,###"
            End If
    
            If (FldType = "Currency3") Then
                objWS1.Columns(a).NumberFormat = "£#,###0"
            End If
    
            If (FldType = "Currency3") Then
                objWS1.Columns(a).NumberFormat = "£#,###0"
            End If
            
                If (FldType = "ShortDate") Then
                objWS1.Columns(a).NumberFormat = "dd/mm/yy;@"
        End If
 
'''''''''''''''''''''
' Re wrap the column'
'''''''''''''''''''''
            objWS1.Cells(1, a).HorizontalAlignment = xlCenter
            objWS1.Cells(1, a).VerticalAlignment = xlBottom
            objWS1.Cells(1, a).WrapText = True
            objWS1.Columns(a).ColumnWidth = ColWidth
 
         Next a
 
' **************
' * Sub Total  *
' **************
    ' Ok so we need to loop through the columns
    Dim STCounter, LoopCounter, iArraySize As Integer ' Sub Total Counter
    STCounter = 0
       
    Dim CurrFldType As Variant
    Dim NumOfColumns As Integer
    
    NumOfColumns = objWS1.Cells(1, 1).CurrentRegion.Columns.Count
    
    a = 1                      ' Increment Counter
    LoopCounter = 0
    
    ' Work out which columns are a number...
    Do
    
      a = a + 1
      CurrFldType = objWS1.Cells(2, a).NumberFormat
      If (Left(CurrFldType, 1) = "£") Then    ' If number format
            ReDim Preserve TotalColumn(STCounter) As Integer
            TotalColumn(STCounter) = a
            STCounter = (STCounter + 1)
            'objWS1.Cells.EntireColumn.AutoFit
      End If
    Loop Until a = NumOfColumns
 
 ' ****************
' Resize the array
' ****************
    iArraySize = UBound(TotalColumn)  ' Find the number of array elements that have been used.
    ReDim Preserve TotalColumn(iArraySize) As Integer  ' Redifine the array to the upper limit
    
' ******************************************
' Display which columns will be sub totalled
' ******************************************
     With objWS1.Cells(1, 1).CurrentRegion
            .RemoveSubtotal
            '.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
                'Replace:=True, PageBreaks:=False, SummaryBelowData:=False
            
            .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
                Replace:=True, PageBreaks:=False, SummaryBelowData:=False
                
     End With
     
     Dim tbl As Object
' ***************************
'   Apply Borders and Totals*
' ***************************
     Set tbl = objWS1.Cells(NumOfRows, 1).CurrentRegion
     
' ************************************
' Complete the formatting on the table
' ************************************
     NumOfRows = objWS1.Cells(1, 1).CurrentRegion.Rows.Count
     a = NumOfRows
     
     NumOfColumns = objWS1.Cells(1, 1).CurrentRegion.Columns.Count
        
     Do
        
        ' *********************************
        ' *  Apply Borders to the table   *
        ' *********************************
        If (objWS1.Cells(a, 1).Font.Bold = True) Then
                
                objWS1.Cells(a, 1).Font.Bold = True
                objWS1.Cells(a, 1).WrapText = False
                objWS1.Cells(a, 1) = objWS1.Cells(a, 1)
 
                    If (objWS1.Cells(a, 1) <> "GRAND TOTAL") Then
                            
                            'Insert a blank row
                            objWS1.Rows(a + 1).Insert Shift:=xlDown
                            objWS1.Cells(a + 1, 1) = "     "
                                                            
                            ' Remove various Borders
                            Set tbl = objWS1.Range(objWS1.Cells(a + 1, 1), objWS1.Cells(a + 1, NumOfColumns))
                            
                            tbl.Select
                            
                            With tbl
                                .Borders(xlEdgeLeft).LineStyle = xlNone
                                '.Borders(xlEdgeTop).LineStyle = xlNone
                               ' .Borders(xlEdgeBottom).LineStyle = xlNone
                                .Borders(xlEdgeRight).LineStyle = xlNone
                                .Borders(xlInsideVertical).LineStyle = xlNone
                            End With
                            
                            Set tbl = objWS1.Range(objWS1.Cells(a, 1), objWS1.Cells(a, NumOfColumns))
                            'tbl.Select
                            
                            With tbl.Borders(xlEdgeTop)
                                .LineStyle = xlContinuous
                                .Weight = xlThin
                                .ColorIndex = xlAutomatic
                            End With
                            
                            ' Insert Page Break after total
                            objWS1.Rows(a + 1).Select
                            objWS1.Cells(a + 1, 1).Activate
 
                    End If
        End If
     a = (a - 1)
     Loop Until a = 0
 
 '***********************************
 'Add a line above the totals column*
 '***********************************
      NumOfColumns = objWS1.Cells(1, 1).CurrentRegion.Columns.Count
     
       'Grand Total
     NumOfRows = objWS1.Cells(1, 1).CurrentRegion.Rows.Count
       If (objWS1.Cells(NumOfRows, 1) = "GRAND TOTAL") Then
        
        'objWS1.Cells(NumOfRows, 11) = ""   ' Blank the Grand Total
        objWS1.Cells(NumOfRows, 1) = "Grand Total"
        objWS1.Cells(NumOfRows, 1).Font.Bold = True
        objWS1.Cells(NumOfRows, 2) = ""
        'objWS1.Cells(NumOfRows, 3) = Null
        'objWS1.Cells(NumOfRows, 3).Font.Bold = False
            
        Set tbl = objWS1.Cells(NumOfRows, 1)
        
        'expression.Range(Cell1, Cell2)
 
        Set tbl = objWS1.Range(objWS1.Cells(NumOfRows, 1), objWS1.Cells(NumOfRows, NumOfColumns))
 
            tbl.Select
        
            tbl.Offset(NumOfRows - 1, 0).Resize(1, tbl.Columns.Count).Select
                    
            ' ******************************
            ' Apply Borders To The Selection
            ' ******************************
            
            'Top Single Border
            With tbl.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .Weight = xlHairline
                    .ColorIndex = 1
            End With
            
            ' Bottom Double Border
            With tbl.Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
            End With
            
            ' Don't bother wrapping the text at the bottom
            ' this will bottom align the text..
            tbl.WrapText = False
        
            objWS1.Cells(NumOfRows, 1).Select
            
        End If
     
        objWS1.Cells(1, 1).Select
        objXLapp.StatusBar = ""
 
 '*******************
 'Resize the columns*
 '*******************
        objWS1.Cells.EntireColumn.AutoFit
        objWS1.Cells.EntireRow.AutoFit
        objWS1.Cells(1, 1).Select
        objXLapp.CutCopyMode = False
        
         NumOfRows = objWS1.Cells(1, 1).CurrentRegion.Rows.Count
 
    ' Apply the borders to the page'
     With objWS1.Cells(1, 1).CurrentRegion.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = 1
     End With
     With objWS1.Cells(1, 1).CurrentRegion.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = 1
     End With
     'With objWS1.Cells(1, 1).CurrentRegion.Borders(xlEdgeBottom)
        '.LineStyle = xlContinuous   'instead of double edge
        '.Weight = xlHairline
        '.ColorIndex = 1
     'End With
     With objWS1.Cells(1, 1).CurrentRegion.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = 1
     End With
     With objWS1.Cells(1, 1).CurrentRegion.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = 1
     End With
     
     If (NumOfRows > 1) Then   ' If there is only 1 row then it will fall over
       With objWS1.Cells(1, 1).CurrentRegion.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = 1
       End With
     End If
    
     
' ***************************************************
' *  Close The Excel Workbook and Then Application  *
' ***************************************************
    objXLapp.Visible = True             ' Excel Visiable on Taskbar
    objXLapp.DisplayAlerts = False
 
    Set objWB = Nothing                 ' Empty Memory of Objects
    Set objWS1 = Nothing
    Set objXLapp = Nothing
    
    DoCmd.SetWarnings (True)
    DoCmd.Hourglass (False)
 
End Sub

Open in new window

Totals.xls

dwe761

Wow. You're asking a lot to look at all of this code. Could you be a little more specific where you're having trouble and how this code fits into your Access application?

Rey Obrero (Capricorn1)

are the columns exported to Excel varies?
are the columns to be totaled always starts at Column D?

aneilg

ASKER

this is the bit of code that does the sum.

if you look at the spreadsheet, the acturl grad total gets displayed, but it's totalling everything by

With objWS1.Cells(1, 1).CurrentRegion
.RemoveSubtotal
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=False

End With

when all i want to display is the grand total

Code that does the sum
' **************
' * Sub Total *
' **************
' Ok so we need to loop through the columns
Dim STCounter, LoopCounter, iArraySize As Integer ' Sub Total Counter
STCounter = 0

Dim CurrFldType As Variant
Dim NumOfColumns As Integer

NumOfColumns = objWS1.Cells(1, 1).CurrentRegion.Columns.Count

a = 1 ' Increment Counter
LoopCounter = 0

' Work out which columns are a number...
Do

'a = 1
a = a + 1
CurrFldType = objWS1.Cells(2, a).NumberFormat
If (Left(CurrFldType, 1) = "£") Then ' If number format
ReDim Preserve TotalColumn(STCounter) As Integer
TotalColumn(STCounter) = a
STCounter = (STCounter + 1)
'objWS1.Cells.EntireColumn.AutoFit
End If
Loop Until a = NumOfColumns

' ****************
' Resize the array
' ****************
iArraySize = UBound(TotalColumn) ' Find the number of array elements that have been used.
ReDim Preserve TotalColumn(iArraySize) As Integer ' Redifine the array to the upper limit

' ******************************************
' Display which columns will be sub totalled
' ******************************************
With objWS1.Cells(1, 1).CurrentRegion
.RemoveSubtotal
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=False

End With

Dim tbl As Object
' ***************************
' Apply Borders and Totals*
' ***************************
Set tbl = objWS1.Cells(NumOfRows, 1).CurrentRegion

' ************************************
' Complete the formatting on the table
' ************************************
NumOfRows = objWS1.Cells(1, 1).CurrentRegion.Rows.Count
a = NumOfRows

NumOfColumns = objWS1.Cells(1, 1).CurrentRegion.Columns.Count

Do

' *********************************
' * Apply Borders to the table *
' *********************************
If (objWS1.Cells(a, 1).Font.Bold = True) Then

objWS1.Cells(a, 1).Font.Bold = True
objWS1.Cells(a, 1).WrapText = False
objWS1.Cells(a, 1) = objWS1.Cells(a, 1)

If (objWS1.Cells(a, 1) <> "GRAND TOTAL") Then

'Insert a blank row
objWS1.Rows(a + 1).Insert Shift:=xlDown
objWS1.Cells(a + 1, 1) = " "

' Remove various Borders
Set tbl = objWS1.Range(objWS1.Cells(a + 1, 1), objWS1.Cells(a + 1, NumOfColumns))

tbl.Select

With tbl
.Borders(xlEdgeLeft).LineStyle = xlNone
'.Borders(xlEdgeTop).LineStyle = xlNone
' .Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
End With

Set tbl = objWS1.Range(objWS1.Cells(a, 1), objWS1.Cells(a, NumOfColumns))
'tbl.Select

With tbl.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

' Insert Page Break after total
objWS1.Rows(a + 1).Select
objWS1.Cells(a + 1, 1).Activate

End If
End If
a = (a - 1)
Loop Until a = 0

aneilg

ASKER

this is prob all i need.
basically i want to loop through all the columns that have a £ in the column then have a grand total displayed at the top.

' **************
' * Sub Total *
' **************
' Ok so we need to loop through the columns
Dim STCounter, LoopCounter, iArraySize As Integer ' Sub Total Counter
STCounter = 0

Dim CurrFldType As Variant
Dim NumOfColumns As Integer

NumOfColumns = objWS1.Cells(1, 1).CurrentRegion.Columns.Count

a = 1 ' Increment Counter
LoopCounter = 0

' Work out which columns are a number...
Do

'a = 1
a = a + 1
CurrFldType = objWS1.Cells(2, a).NumberFormat
If (Left(CurrFldType, 1) = "£") Then ' If number format
ReDim Preserve TotalColumn(STCounter) As Integer
TotalColumn(STCounter) = a
STCounter = (STCounter + 1)
'objWS1.Cells.EntireColumn.AutoFit
End If
Loop Until a = NumOfColumns

' ****************
' Resize the array
' ****************
iArraySize = UBound(TotalColumn) ' Find the number of array elements that have been used.
ReDim Preserve TotalColumn(iArraySize) As Integer ' Redifine the array to the upper limit

' ******************************************
' Display which columns will be sub totalled
' ******************************************
With objWS1.Cells(1, 1).CurrentRegion
.RemoveSubtotal
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=False

End With

aneilg

ASKER

sorry to be a aplin.

But its this bit that seem sto be causing the problem.
' ******************************************
' Display which columns will be sub totalled
' ******************************************
'With objWS1.Cells(1, 1).CurrentRegion
'.RemoveSubtotal
'.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
'Replace:=True, PageBreaks:=False, SummaryBelowData:=False

'End With

The groupby subtotal bit.

Rey Obrero (Capricorn1)

aneilg,
would you care to respond to the questions ask?

aneilg

ASKER

dwe761 asked me to narrow it down to more specific code.

Rey Obrero (Capricorn1)

' ******************************************
' Display which columns will be sub totalled
' ******************************************
' With objWS1.Cells(1, 1).CurrentRegion
' .RemoveSubtotal
' .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=(Array(TotalColumn())), _
' Replace:=True, PageBreaks:=False, SummaryBelowData:=False

' End With

Dim iRow As Integer, iCol As Integer, varCol As String
Dim varColRange As String, vCol As Integer

With objWS1
iRow = .UsedRange.Rows.Count
Debug.Print iRow
iCol = .UsedRange.Columns.Count
For vCol = 4 To iCol
varCol = Chr(vCol + 64) & iRow + 1
varColRange = Chr(vCol + 64) & "2:" & Chr(vCol + 64) & iRow
.Range(varCol).Formula = "=SUM(" & varColRange & ")"
Next
End With

aneilg

ASKER

thanks for that, i've no idea how it works.

Is there any way to display GrandTotal in bold in the column as well.

Once again thanks for your help.

Rey Obrero (Capricorn1)

Dim iRow As Integer, iCol As Integer, varCol As String
Dim varColRange As String, vCol As Integer

With objWS1
iRow = .UsedRange.Rows.Count
iCol = .UsedRange.Columns.Count
For vCol = 4 To iCol
varCol = Chr(vCol + 64) & iRow + 1
varColRange = Chr(vCol + 64) & "2:" & Chr(vCol + 64) & iRow
.Range(varCol).Formula = "=SUM(" & varColRange & ")"
Next
.Range("A" & iRow + 1).Value = "Grand Total"
.Range("A" & iRow + 1).EntireRow.Font.Bold = True
End With

aneilg

ASKER

Dude your a superstar in your own life time.

Sorry just one last question.

Is there an easy way to have this column displayed below the heading.
Or will the calculations be messed up.

ASKER CERTIFIED SOLUTION

Rey Obrero (Capricorn1)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Rey Obrero (Capricorn1)

so, did it work?

aneilg

ASKER

Thankk you so much.
I am just gonna test it now.
Looks fine.

Sorry i have just go tback to you, i was pulled into a meeting last thing last night.

I owe you a few Jars.