Retrieve excel from access (vol 4) , extended format , alternative color (1 Viewer)

L

Leo_Polla_Psemata

Registered User.
Local time
Yesterday, 18:26
Joined
Mar 24, 2014
Messages
364
This is a VBA script from which i export data from access database to an excel.
The excel looks like this and may contain 2000 or more lines.
Freight-Lisrt-Example.jpg

I have removed several lines from the code, those lines that format and calculate, just to make it shorter.

My "goal" now is to apply an alternative background color every time data in column "A" change.

Code: 
Private Sub Fr_Click()
On Error GoTo SubError
        
    DoCmd.SetWarnings False
    DoCmd.RunSQL strUP1
    DoCmd.RunSQL strUP2
    DoCmd.SetWarnings True
    Me.Refresh
 
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim SQL As String
    Dim rsFR As DAO.Recordset
    Dim i As Integer
 
    'Show user work is being performed
    DoCmd.Hourglass (True)
 
    '*********************************************
    '              RETRIEVE DATA
    '*********************************************
    'SQL statement to retrieve data from database



SQL = " SELECT AAV.Acti, FREIGHT.BL, .... " ' SQL statement


'Execute query and populate recordset
    Set rsFR = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

   'If no data, don't bother opening Excel, just quit
    If rsFR.RecordCount = 0 Then
        MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
        GoTo SubExit
    End If

    '*********************************************
    '             BUILD SPREADSHEET
    '*********************************************
    'Create an instance of Excel and start building a spreadsheet
 
    'Early Binding
    Set xlApp = Excel.Application
    xlApp.Visible = False
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    Range("A10").Select
    ActiveWindow.FreezePanes = True
    xlSheet.Activate
    ActiveWindow.DisplayGridlines = False


    With xlSheet
            .Name = "Freight List " & IRISvoy
            .Cells.Font.Name = "Calibri"
            .Cells.Font.Size = 10

       'Set column widths
        .Columns("A").ColumnWidth = 14
        .Columns("B").ColumnWidth = 14
        .Rows("9:9").RowHeight = 50
        .Range("A9:Q9").Interior.Color = RGB(207, 207, 207)
        .Range("D9", "I9").Orientation = 90
        .Range("K10:K2500").NumberFormat = "@"
        
  ' Extended lines cuted
  
   .Range("C8").Formula = "=SUM(I10:I" & i - 1 & ")"


' format the table , lines cuted
       .Range("D2:D6").Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
       .Range("C2:C6").Borders(xlEdgeLeft).LineStyle = XlLineStyle.xlContinuous
        .Range("C2", "D2").Merge


        'Format columns  , lines cuted
        .Range("A2").Value = "VESSEL  "
        .Range("B2").Value = vesselName
        .Range("B4").NumberFormat = "[$-en-US]d-mmm-yyyy;@"
        .Range("E2", "L2").NumberFormat = "$#,##0.00"
        .Range("E3", "L3").NumberFormat = "[$€‚¬-x-euro2] #,##0.00"
        .Range("E4", "L4").NumberFormat = "[$£-en-GB]#,##0.00"
        .Range("E5", "L5").NumberFormat = "[$¥-zh-CN]#,##0.00"


        'provide initial value to row counter
        
        i = 10

'        'Loop through recordset and copy data from recordset to sheet
        Do While Not rsFR.EOF

        .Range("A" & i).Value = Nz(rsFR!bl, "")
        .Range("B" & i).Value = Nz(rsFR!bk, "")
        .Range("C" & i).Value = Nz(rsFR!BLline, "")
' extended lines removed
        
            i = i + 1
            rsFR.MoveNext
'
           Loop
    
         .Range("B5").Formula = "=SUMPRODUCT(1/COUNTIF(A10" & ":A" & i - 1 & " ,A10" & ":A" & i - 1 & " ))"
         .Range("B6").Formula = "=SUMPRODUCT(1/COUNTIF(C10" & ":C" & i - 1 & " ,C10" & ":C" & i - 1 & " ))"
        
         .Range("L10" & ":O" & i).Cells.Font.Size = 7
        
   .Range("E2").Formula = "=SUMIFS(I10" & ":I" & i - 1 & " ,D10" & ":D" & i - 1 & " ," & """OFT""" & ",F10" & ":F" & i - 1 & " ," & """USD""" & ", J10" & ":J" & i - 1 & " ," & """P"")"
   .Range("E3").Formula = "=SUMIFS(I10" & ":I" & i - 1 & " ,D10" & ":D" & i - 1 & " ," & """OFT""" & ",F10" & ":F" & i - 1 & " ," & """EUR""" & ", J10" & ":J" & i - 1 & " ," & """P"")"
   .Range("E4").Formula = "=SUMIFS(I10" & ":I" & i - 1 & " ,D10" & ":D" & i - 1 & " ," & """OFT""" & ",F10" & ":F" & i - 1 & " ," & """GBP""" & ", J10" & ":J" & i - 1 & " ," & """P"")"
  
  
       .Range("A" & i - 1 & ":O" & i - 1).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlDouble
       .Range("A10" & ":O" & i - 1).Borders(xlInsideHorizontal).LineStyle = XlLineStyle.xlContinuous
       .Range("A10" & ":O" & i - 1).Borders(xlInsideVertical).LineStyle = XlLineStyle.xlContinuous
       .Range("A10" & ":O" & i - 1).Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
  
        .Range("B9" & ":B" & i - 1).HorizontalAlignment = xlCenter

        With .Range("J10:J" & i).FormatConditions.Add(xlCellValue, xlEqual, "<>""F""")

         .Interior.Color = RGB(150, 150, 50)

        End With
                
    
End With

SubExit:
On Error Resume Next
    DoCmd.Hourglass False
    xlApp.Visible = True
    rsFR.Close
    Set rsFR = Nothing
    Exit Sub
  
SubError:
    MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
        "An error occurred"
    GoTo SubExit
End Sub

If you could help me by adding extra vba code pieces, it would be just great.
 
not sure how you would do that in excel but here is a way to do it in access - you can probably apply a similar method if you export the rownumber value as well

Making a form look like a report

As a result of this post https://www.access-programmers.co.uk/forums/threads/emulate-reports-grouping-levels-with-forms.326697/ I thought I would diddle around and come up with some examples. This is a simple format - only shows the customer once and uses conditional formatting to change the...
www.access-programmers.co.uk

See the simple example
 
which Column is "BL"?
 
Code: 
Dim arr As Variant, sValue As String
Dim i As Long, style As String
style = "Normal"
With xlSheet
    arr = .Range("a10:a" & .Range("a10").End(-4121).Row)
    For i = 1 To UBound(arr, 1)
        If sValue <> arr(i, 1) Then
            If Len(sValue) <> 0 Then
                style = IIf(style = "Normal", "Note", "Normal")
            End If
            sValue = arr(i, 1)
        End If
        .Rows(10 + i - 1).style = style
    Next
End With
 
Last edited:
adding extra vba code pieces
Click to expand...
The procedure is already way too long and way too confusing, especially since the code formatting seems quite random and is not really helpful.

Instead of creating a new workbook from scratch, you could make a copy of a template with all the formatting and formulas you need and copy the data from the database into it, preferably using a bulk action (CopyFromRecordset).

The color changes could be initiated by conditional formatting directly in the Excel sheet.
Code: 
SQL = " SELECT AAV.Acti, FREIGHT.BL, .... " ' SQL statement
You could create an additional column in the query with the sequence number on Acti.
You can react to this with conditional formatting:
Code: 
SeqNumber mod 2
 
i inserted my new code to your original code:
Code: 
Private Sub Fr_Click()
On Error GoTo SubError
        
    DoCmd.SetWarnings False
    DoCmd.RunSQL strUP1
    DoCmd.RunSQL strUP2
    DoCmd.SetWarnings True
    Me.Refresh
 
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim SQL As String
    Dim rsFR As DAO.Recordset
    Dim i As Long
 
    'Show user work is being performed
    DoCmd.Hourglass (True)
 
    '*********************************************
    '              RETRIEVE DATA
    '*********************************************
    'SQL statement to retrieve data from database



SQL = " SELECT AAV.Acti, FREIGHT.BL, .... " ' SQL statement


'Execute query and populate recordset
    Set rsFR = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

   'If no data, don't bother opening Excel, just quit
    If rsFR.RecordCount = 0 Then
        MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
        GoTo SubExit
    End If

    '*********************************************
    '             BUILD SPREADSHEET
    '*********************************************
    'Create an instance of Excel and start building a spreadsheet
 
    'Early Binding
    Set xlApp = Excel.Application
    xlApp.Visible = False
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    Range("A10").Select
    ActiveWindow.FreezePanes = True
    xlSheet.Activate
    ActiveWindow.DisplayGridlines = False


    With xlSheet
            .Name = "Freight List " & IRISvoy
            .Cells.Font.Name = "Calibri"
            .Cells.Font.Size = 10

       'Set column widths
        .Columns("A").ColumnWidth = 14
        .Columns("B").ColumnWidth = 14
        .Rows("9:9").RowHeight = 50
        .Range("A9:Q9").Interior.Color = RGB(207, 207, 207)
        .Range("D9", "I9").Orientation = 90
        .Range("K10:K2500").NumberFormat = "@"
        
  ' Extended lines cuted
 
   .Range("C8").Formula = "=SUM(I10:I" & i - 1 & ")"


' format the table , lines cuted
       .Range("D2:D6").Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
       .Range("C2:C6").Borders(xlEdgeLeft).LineStyle = XlLineStyle.xlContinuous
        .Range("C2", "D2").Merge


        'Format columns  , lines cuted
        .Range("A2").Value = "VESSEL  "
        .Range("B2").Value = vesselName
        .Range("B4").NumberFormat = "[$-en-US]d-mmm-yyyy;@"
        .Range("E2", "L2").NumberFormat = "$#,##0.00"
        .Range("E3", "L3").NumberFormat = "[$€‚¬-x-euro2] #,##0.00"
        .Range("E4", "L4").NumberFormat = "[$£-en-GB]#,##0.00"
        .Range("E5", "L5").NumberFormat = "[$¥-zh-CN]#,##0.00"


        'provide initial value to row counter
        
        i = 10

'        'Loop through recordset and copy data from recordset to sheet
        Do While Not rsFR.EOF

        .Range("A" & i).Value = Nz(rsFR!bl, "")
        .Range("B" & i).Value = Nz(rsFR!bk, "")
        .Range("C" & i).Value = Nz(rsFR!BLline, "")
' extended lines removed
        
            i = i + 1
            rsFR.MoveNext
'
           Loop
    
         .Range("B5").Formula = "=SUMPRODUCT(1/COUNTIF(A10" & ":A" & i - 1 & " ,A10" & ":A" & i - 1 & " ))"
         .Range("B6").Formula = "=SUMPRODUCT(1/COUNTIF(C10" & ":C" & i - 1 & " ,C10" & ":C" & i - 1 & " ))"
        
         .Range("L10" & ":O" & i).Cells.Font.Size = 7
        
   .Range("E2").Formula = "=SUMIFS(I10" & ":I" & i - 1 & " ,D10" & ":D" & i - 1 & " ," & """OFT""" & ",F10" & ":F" & i - 1 & " ," & """USD""" & ", J10" & ":J" & i - 1 & " ," & """P"")"
   .Range("E3").Formula = "=SUMIFS(I10" & ":I" & i - 1 & " ,D10" & ":D" & i - 1 & " ," & """OFT""" & ",F10" & ":F" & i - 1 & " ," & """EUR""" & ", J10" & ":J" & i - 1 & " ," & """P"")"
   .Range("E4").Formula = "=SUMIFS(I10" & ":I" & i - 1 & " ,D10" & ":D" & i - 1 & " ," & """OFT""" & ",F10" & ":F" & i - 1 & " ," & """GBP""" & ", J10" & ":J" & i - 1 & " ," & """P"")"
 
 
       .Range("A" & i - 1 & ":O" & i - 1).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlDouble
       .Range("A10" & ":O" & i - 1).Borders(xlInsideHorizontal).LineStyle = XlLineStyle.xlContinuous
       .Range("A10" & ":O" & i - 1).Borders(xlInsideVertical).LineStyle = XlLineStyle.xlContinuous
       .Range("A10" & ":O" & i - 1).Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
 
        .Range("B9" & ":B" & i - 1).HorizontalAlignment = xlCenter

        With .Range("J10:J" & i).FormatConditions.Add(xlCellValue, xlEqual, "<>""F""")

         .Interior.Color = RGB(150, 150, 50)

        End With
                
    
    ' arnelgp
    ' feb-22-2023
    ' Alternate coloring based on Value of column A
    '
    Dim arr As Variant, sValue As String
    Dim style As String
    style = "Normal"
    arr = .Range("A10:A" & .Range("A10").End(-4121).Row)
    For i = 1 To UBound(arr, 1)
        If sValue <> arr(i, 1) Then
            If Len(sValue) <> 0 Then
                style = IIf(style = "Normal", "Note", "Normal")
            End If
            sValue = arr(i, 1)
        End If
        .Rows(10 + i - 1).style = style
    Next
End With

SubExit:
On Error Resume Next
    DoCmd.Hourglass False
    xlApp.Visible = True
    rsFR.Close
    Set rsFR = Nothing
    Exit Sub
 
SubError:
    MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
        "An error occurred"
    GoTo SubExit
End Sub
 
You must log in or register to reply here.

Similar threads

L
Formula syntax and punctuation
Replies
7
Views
968
Leo_Polla_Psemata
L
L
Solved Extract excel from access
Replies
4
Views
812
Leo_Polla_Psemata
L
J
Opening & formatting Excel spreadsheet from VBA
Replies
7
Views
3,064
J_Orrell
J
P
how to export or save as in vba code
Replies
0
Views
982
pujangga2007
P
Y
VBA code for exporting an Access crosstab query into an excel template
Replies
6
Views
2,525
JHB
J

Users who are viewing this thread

Total: 2 (members: 0, guests: 2)
Back
Top Bottom