We help IT Professionals succeed at work.

Writing data to excel

jackjeckyl
jackjeckyl asked
on
I need code to write data to an excel file.  There are basically 6 columns per row and the file will be created every day.  The data is coming from a database, which I can do, can you give me some code on how to export the data to excel?
Comment
Watch Question

Commented:
The really easy way is to just write a csv file.  


dim tmprecord as string



open "c:/output.csv" for append as #1

tmprecord = tmprecord & field1 & ", " & field2 & ", " tmprecord = tmprecord & field3 & ", " field4 & ", " & tmprecord = tmprecord & field5 & vbcrlf

write #1,, tmprecord

Commented:
   Dim oExcel    As Excel.Application
    Dim objExlBook As Workbook
    Dim objExlSht As Worksheet ' OLE automation object
   
        On Error Resume Next
        Set oExcel = GetObject(, "Excel.Application")
        ' if Excel is not launched start it
        If Err = 429 Then
            Err = 0
            Set oExcel = CreateObject("Excel.Application")
            ' can't create object
            If Err = 429 Then
                MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
                Exit Sub
            End If
        End If
        Set objExlBook = oExcel.Workbooks.Open("mybook.xls")
        Set objExlSht = objExlBook.Sheets(1)
       
        with objExlSht
             .cells("A1")=yourRS.fields("yourfield")
        end with
        ' give the user control
        oExcel.Visible = true
        oExcel.Interactive = True
         objExlBook.Close
        oExcel.Quit
        ' clean up (I test if objects are still "alive" to avoid errors):
        If Not (objExlSht Is Nothing) Then
            Set objExlSht = Nothing ' Remove object variable
        End If
        If Not (objExlBook Is Nothing) Then
            Set objExlBook = Nothing ' Remove object variable
        End If
        If Not (oExcel Is Nothing) Then
            Set oExcel = Nothing    ' Remove object variable
        End If
       

Author

Commented:
How can I get it to go to B1 after A6 is populated?

Author

Commented:
To automatically do it, that is.

Author

Commented:
darth, I need to send it out as a .xls file so I just assume write it into an .xls file.
Commented:
replace the following code :
'******************
 with objExlSht
            .cells("A1")=yourRS.fields("yourfield")
 end with
'******************

with this:

'******************
Dim objRange As Range
dim rowNo as long


Set objRange = objExlSht.Range("A1")

while not yourRS.EOF
With objRange
        .Offset(RowNo, 0) = yourRS.fields("yourfield1")
        .Offset(RowNo, 1) = yourRS.fields("yourfield2")
        .Offset(RowNo, 2) = yourRS.fields("yourfield3")
        .Offset(RowNo, 3) = yourRS.fields("yourfield4")
        .Offset(RowNo, 4) = yourRS.fields("yourfield5")
        .Offset(RowNo, 5) = yourRS.fields("yourfield6")
        RowNo = RowNo + 1
        yourRS.movenext
End With
loop
Mike McCrackenSenior Consultant
CERTIFIED EXPERT
Most Valuable Expert 2011
Top Expert 2013

Commented:
listening

Author

Commented:
OK, so far so good.  But one big problem, it doesn't save.  Here's the meat of the code as i have it.  sExtractFile is the path and a global variable.

  Dim sSQL, sWHERE As String
  Dim rsDetail As Recordset
  Dim dbWhlsle As Database
  Dim lngTotItems, lngBatchNum, lngBatItem, lngTranTot As Long
  Dim dblTotAmount, dblBatAmount As Double
  Dim tmpBatch, tmpTrans As String
  Dim sCheckTable As String
  Dim oExcel    As Excel.Application
  Dim objExlBook As Workbook
  Dim objExlSht As Worksheet ' OLE automation object
  Dim objRange As Range
  Dim rowNo As Long

    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")
    ' if Excel is not launched start it
    If Err = 429 Then
        Err = 0
        Set oExcel = CreateObject("Excel.Application")
        ' can't create object
        If Err = 429 Then
            MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
            Exit Sub
        End If
    End If
       
  Set objExlBook = oExcel.Workbooks.Open(sExtractFile)
  Set objExlSht = objExlBook.Sheets(1)
       
  sCheckTable = "Checks_" & sBankNum & "_" & sCustNum
 
  lngTranTot = 0
  lngBatchNum = 0
  lngBatItem = 0
  dblBatAmount = 0#
  lngTotItems = 0
  dblTotAmount = 0#
  tmpBatch = ""
  tmpTrans = ""
 
  sWHERE = "WHERE Inv.depositDate = '" & sDate & "' "
  If txtExtract <> "N" Then
    sWHERE = " INNER JOIN Custom_Extract Ext ON (" & _
        "Check.BankID = Ext.BankID " & _
         "AND Check.Lockbox = Ext.Lockbox " & _
         "AND Check.depositDate = Ext.Day " & _
         "AND Check.Batch = Ext.Batch " & _
         sWHERE & _
         "AND Ext.Ext_Number = " & lngExtNum & " "
  End If
 
  sSQL = "SELECT Check.Batch, Check.TransNum, Inv.DMP_InvNum, " & _
         "Inv.Inv_, Check.AMOUNT, Inv.Inv_Amt, " & _
         "Check.SERIAL, Check.RT, " & _
         "Check.ACCOUNT " & _
         "FROM (Check LEFT OUTER JOIN " & sTableName & " Inv ON (" & _
         "Check.BankID = Inv.BankID " & _
         "AND Check.Lockbox = Inv.Lockbox " & _
         "AND Check.Batch = Inv.Batch " & _
         "AND Check.depositDate = Inv.depositDate " & _
         "AND Check.TransNum = Inv.TransNum ))" & _
         sWHERE & _
         "ORDER BY Check.Batch, Check.TransNum, Inv.DMP_InvNum "
 
Set objRange = objExlSht.Range("A1")
Set dbWhlsle = OpenDatabase(sWhlslDBLocation, False, True)
Set rsDetail = dbWhlsle.OpenRecordset(sSQL, dbOpenSnapshot, dbForwardOnly)
 
  With rsDetail
    Do While Not .EOF
        With objRange
            If tmpBatch <> rsDetail("Batch") Then
                If tmpBatch <> "" Then
                      'Add batch total to extract array
                      Add_Batch sDate, (tmpBatch), (lngBatItem), (dblBatAmount)
                End If
            tmpBatch = rsDetail("Batch")
            lngBatchNum = lngBatchNum + 1
            dblBatAmount = 0#
            lngBatItem = 0
            End If
            .Offset(rowNo, 0) = rsDetail("amount")
            .Offset(rowNo, 1) = rsDetail("rt")
            .Offset(rowNo, 2) = rsDetail("account")
            .Offset(rowNo, 3) = rsDetail("serial")
            .Offset(rowNo, 4) = rsDetail("inv_")
            .Offset(rowNo, 5) = rsDetail("inv_amt")
            rowNo = rowNo + 1
            lngTotItems = lngTotItems + 1
            lngBatItem = lngBatItem + 1
            dblBatAmount = dblBatAmount + rsDetail("amount")
            dblTotAmount = dblTotAmount + rsDetail("amount")
        End With
        .MoveNext
    Loop
  .Close
End With
dbWhlsle.Close
 
  'Add batch total to extract array
  Add_Batch sDate, (tmpBatch), (lngBatItem), (dblBatAmount)
 
  objExlBook.Save
    objExlBook.SaveAs sExtractFile
    objExlBook.Close
   
    oExcel.Quit
    ' clean up (I test if objects are still "alive" to avoid errors):
    If Not (objExlSht Is Nothing) Then
        Set objExlSht = Nothing ' Remove object variable
    End If
    If Not (objExlBook Is Nothing) Then
        Set objExlBook = Nothing ' Remove object variable
    End If
    If Not (oExcel Is Nothing) Then
        Set oExcel = Nothing    ' Remove object variable
    End If


Author

Commented:
OK, so far so good.  But one big problem, it doesn't save.  Here's the meat of the code as i have it.  sExtractFile is the path and a global variable.

  Dim sSQL, sWHERE As String
  Dim rsDetail As Recordset
  Dim dbWhlsle As Database
  Dim lngTotItems, lngBatchNum, lngBatItem, lngTranTot As Long
  Dim dblTotAmount, dblBatAmount As Double
  Dim tmpBatch, tmpTrans As String
  Dim sCheckTable As String
  Dim oExcel    As Excel.Application
  Dim objExlBook As Workbook
  Dim objExlSht As Worksheet ' OLE automation object
  Dim objRange As Range
  Dim rowNo As Long

    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")
    ' if Excel is not launched start it
    If Err = 429 Then
        Err = 0
        Set oExcel = CreateObject("Excel.Application")
        ' can't create object
        If Err = 429 Then
            MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
            Exit Sub
        End If
    End If
       
  Set objExlBook = oExcel.Workbooks.Open(sExtractFile)
  Set objExlSht = objExlBook.Sheets(1)
       
  sCheckTable = "Checks_" & sBankNum & "_" & sCustNum
 
  lngTranTot = 0
  lngBatchNum = 0
  lngBatItem = 0
  dblBatAmount = 0#
  lngTotItems = 0
  dblTotAmount = 0#
  tmpBatch = ""
  tmpTrans = ""
 
  sWHERE = "WHERE Inv.depositDate = '" & sDate & "' "
  If txtExtract <> "N" Then
    sWHERE = " INNER JOIN Custom_Extract Ext ON (" & _
        "Check.BankID = Ext.BankID " & _
         "AND Check.Lockbox = Ext.Lockbox " & _
         "AND Check.depositDate = Ext.Day " & _
         "AND Check.Batch = Ext.Batch " & _
         sWHERE & _
         "AND Ext.Ext_Number = " & lngExtNum & " "
  End If
 
  sSQL = "SELECT Check.Batch, Check.TransNum, Inv.DMP_InvNum, " & _
         "Inv.Inv_, Check.AMOUNT, Inv.Inv_Amt, " & _
         "Check.SERIAL, Check.RT, " & _
         "Check.ACCOUNT " & _
         "FROM (Check LEFT OUTER JOIN " & sTableName & " Inv ON (" & _
         "Check.BankID = Inv.BankID " & _
         "AND Check.Lockbox = Inv.Lockbox " & _
         "AND Check.Batch = Inv.Batch " & _
         "AND Check.depositDate = Inv.depositDate " & _
         "AND Check.TransNum = Inv.TransNum ))" & _
         sWHERE & _
         "ORDER BY Check.Batch, Check.TransNum, Inv.DMP_InvNum "
 
Set objRange = objExlSht.Range("A1")
Set dbWhlsle = OpenDatabase(sWhlslDBLocation, False, True)
Set rsDetail = dbWhlsle.OpenRecordset(sSQL, dbOpenSnapshot, dbForwardOnly)
 
  With rsDetail
    Do While Not .EOF
        With objRange
            If tmpBatch <> rsDetail("Batch") Then
                If tmpBatch <> "" Then
                      'Add batch total to extract array
                      Add_Batch sDate, (tmpBatch), (lngBatItem), (dblBatAmount)
                End If
            tmpBatch = rsDetail("Batch")
            lngBatchNum = lngBatchNum + 1
            dblBatAmount = 0#
            lngBatItem = 0
            End If
            .Offset(rowNo, 0) = rsDetail("amount")
            .Offset(rowNo, 1) = rsDetail("rt")
            .Offset(rowNo, 2) = rsDetail("account")
            .Offset(rowNo, 3) = rsDetail("serial")
            .Offset(rowNo, 4) = rsDetail("inv_")
            .Offset(rowNo, 5) = rsDetail("inv_amt")
            rowNo = rowNo + 1
            lngTotItems = lngTotItems + 1
            lngBatItem = lngBatItem + 1
            dblBatAmount = dblBatAmount + rsDetail("amount")
            dblTotAmount = dblTotAmount + rsDetail("amount")
        End With
        .MoveNext
    Loop
  .Close
End With
dbWhlsle.Close
 
  'Add batch total to extract array
  Add_Batch sDate, (tmpBatch), (lngBatItem), (dblBatAmount)
 
  objExlBook.Save
    objExlBook.SaveAs sExtractFile
    objExlBook.Close
   
    oExcel.Quit
    ' clean up (I test if objects are still "alive" to avoid errors):
    If Not (objExlSht Is Nothing) Then
        Set objExlSht = Nothing ' Remove object variable
    End If
    If Not (objExlBook Is Nothing) Then
        Set objExlBook = Nothing ' Remove object variable
    End If
    If Not (oExcel Is Nothing) Then
        Set oExcel = Nothing    ' Remove object variable
    End If


Author

Commented:
I can get it to save, but I don't want it to pop up and ask for overwriting and save changes.  I just want it to automatically do it!

Author

Commented:
I have a follow up question posted.

Commented:
Hi. Thanks for the points and grade. I havn't back to see the site for a while.
Here is the way get rid of the alert.
before you save the workbook, turn the alert off.

oExcel.AlertBeforeOverwriting=false

Cheers,
GoodJun

Explore More ContentExplore courses, solutions, and other research materials related to this topic.