Code for updating cells in an Excel spreadsheet

[M Owen]

Hi all

Anyone throw me a snippet or link to some code that examples populating cells in an Excel spreadsheet? I have (or will have) a template spreadsheet that will be filled programmatically from within Access 2000 ... Just wanted a little primer on do it ... Thanks.

- Mike

[Granty]

A long old sub I wrote a while back, has a lot of Excel stuff in it.

Private Sub ExportDetailToExcel(SQLString As String)


Dim XLApp As Excel.Application
Dim XLBook As Excel.Workbook
Dim XLSheet As Excel.Worksheet

Dim intCol As Integer

Dim lngRow As Long
Dim lngUseFlag As Long
Dim lngOpFlag As Long
Dim lngJVFlag As Long
Dim lngTypeFlag As Long

Dim strFileName As String
Dim strUse As String
Dim strType As String
Dim strJV As String
Dim strOp As String

Dim fld As Field

Dim OutputFile As clsDialogs

  Set rs = New ADODB.Recordset
  rs.Open SQLString, db.SecureConnection, adOpenForwardOnly, adLockReadOnly, adCmdText
  
  Set XLApp = New Excel.Application
  Set XLBook = XLApp.Workbooks.Add
  Set XLSheet = XLBook.ActiveSheet
  
  intCol = 1
  lngRow = 1
    
  For Each fld In rs.Fields
  
    XLSheet.Cells(lngRow, intCol) = fld.Name
    intCol = intCol + 1
    
  Next fld
  
  intCol = 1
  lngRow = 2
  
  lngOpFlag = 2
  lngUseFlag = 2
  lngJVFlag = 2
  lngTypeFlag = 2
  
  strUse = rs!ZBTrafficUse
  strType = rs!CHRType
  strJV = rs!Venture
  strOp = rs!CHROpname
   
  Do While Not rs.EOF

    For Each fld In rs.Fields
    
      XLSheet.Cells(lngRow, intCol) = fld.Value
      intCol = intCol + 1
      
    Next fld
    
    intCol = 1
    lngRow = lngRow + 1
           
    rs.MoveNext
      
    If Not rs.EOF Then
    
      If (rs!ZBTrafficUse <> strUse) Or (rs!CHRType <> strType) _
        Or (rs!Venture <> strJV) Or (rs!CHROpname <> strOp) Then
      
        XLSheet.Cells(lngRow, 6) = "Total " & strUse
        XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngUseFlag & ")"
        XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngUseFlag & ")"
        XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngUseFlag & ")"
                       
        XLApp.Range("F" & lngRow, "J" & lngRow).Select
        XLApp.Selection.Interior.ColorIndex = 43
        XLApp.Selection.Interior.Pattern = xlSolid
        
        lngRow = lngRow + 1
        
        lngUseFlag = lngRow
               
        strUse = rs!ZBTrafficUse
      
      End If
            
      If rs!Venture <> strJV Then
              
        XLSheet.Cells(lngRow, 3) = "Total " & strJV
        XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngJVFlag & ")"
        XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngJVFlag & ")"
        XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngJVFlag & ")"
                       
        XLApp.Range("C" & lngRow, "J" & lngRow).Select
        XLApp.Selection.Interior.ColorIndex = 40
        XLApp.Selection.Interior.Pattern = xlSolid
                       
        lngRow = lngRow + 1
        
        lngUseFlag = lngRow
        lngJVFlag = lngRow
        
        strJV = rs!Venture
                
      End If
      
      If rs!CHRType <> strType Then
      
        XLSheet.Cells(lngRow, 2) = "Total " & strType
        XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngTypeFlag & ")"
        XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngTypeFlag & ")"
        XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngTypeFlag & ")"
                
        XLApp.Range("B" & lngRow, "J" & lngRow).Select
        XLApp.Selection.Interior.ColorIndex = 37
        XLApp.Selection.Interior.Pattern = xlSolid
                
        lngRow = lngRow + 1
        
        lngUseFlag = lngRow
        lngJVFlag = lngRow
        lngTypeFlag = lngRow
            
        strType = rs!CHRType
               
      End If
      
      If rs!CHROpname <> strOp Then
            
        XLSheet.Cells(lngRow, 1) = "Total " & strOp
        XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngOpFlag & ")"
        XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngOpFlag & ")"
        XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngOpFlag & ")"
        
        XLApp.Range("A" & lngRow, "J" & lngRow).Select
        XLApp.Selection.Interior.ColorIndex = 35
        XLApp.Selection.Interior.Pattern = xlSolid
        
        lngRow = lngRow + 1
        
        lngUseFlag = lngRow
        lngJVFlag = lngRow
        lngTypeFlag = lngRow
        lngOpFlag = lngRow
                     
        strOp = rs!CHROpname
               
      End If
                
    End If
                
  Loop
  
  XLSheet.Cells(lngRow, 6) = "Total " & strUse
  XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngUseFlag & ")"
  XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngUseFlag & ")"
  XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngUseFlag & ")"
                 
  XLApp.Range("F" & lngRow, "J" & lngRow).Select
  XLApp.Selection.Interior.ColorIndex = 43
  XLApp.Selection.Interior.Pattern = xlSolid
  
  lngRow = lngRow + 1
  
  XLSheet.Cells(lngRow, 3) = "Total " & strJV
  XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngJVFlag & ")"
  XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngJVFlag & ")"
  XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngJVFlag & ")"
                 
  XLApp.Range("C" & lngRow, "J" & lngRow).Select
  XLApp.Selection.Interior.ColorIndex = 40
  XLApp.Selection.Interior.Pattern = xlSolid
  
  lngRow = lngRow + 1
  
  XLSheet.Cells(lngRow, 2) = "Total " & strType
  XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngTypeFlag & ")"
  XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngTypeFlag & ")"
  XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngTypeFlag & ")"
          
  XLApp.Range("B" & lngRow, "J" & lngRow).Select
  XLApp.Selection.Interior.ColorIndex = 37
  XLApp.Selection.Interior.Pattern = xlSolid
          
  lngRow = lngRow + 1
  
  XLSheet.Cells(lngRow, 1) = "Total " & strOp
  XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H" & lngOpFlag & ")"
  XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I" & lngOpFlag & ")"
  XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J" & lngOpFlag & ")"
  
  XLApp.Range("A" & lngRow, "J" & lngRow).Select
  XLApp.Selection.Interior.ColorIndex = 35
  XLApp.Selection.Interior.Pattern = xlSolid
  
  lngRow = lngRow + 2
  
  XLSheet.Cells(lngRow, 1) = "Report Totals "
  XLSheet.Cells(lngRow, 8) = "=subtotal(9,H" & lngRow - 1 & ":H2)"
  XLSheet.Cells(lngRow, 9) = "=subtotal(9,I" & lngRow - 1 & ":I2)"
  XLSheet.Cells(lngRow, 10) = "=subtotal(9,J" & lngRow - 1 & ":J2)"
       
  XLApp.Range("A" & lngRow, "J" & lngRow).Select
  XLApp.Selection.Interior.ColorIndex = 15
  XLApp.Selection.Interior.Pattern = xlSolid
      
  XLApp.Selection.Font.Bold = True
   
  With XLApp.Selection.Borders(xlEdgeTop)
  
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    
  End With
         
  With XLApp.Selection.Borders(xlEdgeBottom)
  
    .LineStyle = xlDouble
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    
  End With
  
  XLApp.Range("A1:K1").Select
  XLApp.Selection.Font.Bold = True
  
  XLApp.Columns("A:K").EntireColumn.AutoFit
         
  XLApp.Range("A1", "J" & lngRow).Select
  XLApp.Selection.NumberFormat = "$#,##0.00"
  
  XLApp.Range("K1", "K" & lngRow).Select
  XLApp.Selection.NumberFormat = "0.0000"
  
  XLApp.Range("A1").Select

  Set OutputFile = New clsDialogs
  OutputFile.DialogTitle = "Please Save Output Data"
  OutputFile.ShowSave
  strFileName = OutputFile.FileName
  
  If Not IsNothing(strFileName) Then XLSheet.SaveAs strFileName
  
  Set OutputFile = Nothing
  
  rs.Close
  Set rs = Nothing
          
  MsgBox "Output successful", vbInformation, "Process Complete"
 
  XLApp.Quit
  Set XLSheet = Nothing
  Set XLBook = Nothing
  Set XLApp = Nothing
  Exit Sub

Hope that helps

[M Owen]

Granty,

Thanks for the code!!!!

- Mike