Solved

How to export data into excel files?

Posted on 2004-04-27
8
22,363 Views
Last Modified: 2012-06-27
I am writing a program to export data into excel files, I want to different data into different cells (column) in excel file. For example, I want to output Month, Price and no. of Cards into different column in excel:

Month          Price         No.of Cards
Jan              100           15
Feb              111           18
March           120          25
April             150          22
May              9             35

Put all this data into different cells in excel file automatically from VB program
I am using 'FileSystemObject'  and 'TextStream' to output data file
0
Comment
Question by:musinc
8 Comments
 
LVL 14

Accepted Solution

by:
Farzad Akbarnejad earned 30 total points
ID: 10935912
Hi,
seperate each cells with comma in you output file:

Month,Price,"No.of, Cards"
Jan,100,15
Feb,111,18
March,120,25
April,150,22
May,9,35

Then save this file with .csv (comma seperated values) extension. Double click on the result output file (with .csv extension). Excel opens it and show each value in a cell.

Thanks
-FA

0
 

Expert Comment

by:Jenith
ID: 10936156
this works with great
0
 
LVL 18

Expert Comment

by:Dennis Aries
ID: 11059442
Put the code below in a Class, and you can use an instance of that class to create and write to an Excel-file. You can specify the type of the cell and/or write to a cell directly. I believe the fileformat is excel 4.x, but that does not matter for the later versions. I use this code to export from my applications and it never failed me.

'enum to handle the various types of values that can be written
'to the excel file.
Public Enum ValueTypes
    xlsInteger = 0
    xlsNumber = 1
    xlsText = 2
End Enum

'enum to hold cell alignment
Public Enum CellAlignment
    xlsGeneralAlign = 0
    xlsLeftAlign = 1
    xlsCentreAlign = 2
    xlsRightAlign = 3
    xlsFillCell = 4
    xlsLeftBorder = 8
    xlsRightBorder = 16
    xlsTopBorder = 32
    xlsBottomBorder = 64
    xlsShaded = 128
End Enum

'enum to handle selecting the font for the cell
Public Enum CellFont
    'used by rgbAttr2
    'bits 0-5 handle the *picture* formatting, not bold/underline etc...
    'bits 6-7 handle the font number
    xlsFont0 = 0
    xlsFont1 = 64
    xlsFont2 = 128
    xlsFont3 = 192
End Enum

Public Enum CellHiddenLocked
    'used by rgbAttr1
    'bits 0-5 must be zero
    'bit 6 locked/unlocked
    'bit 7 hidden/not hidden
    xlsNormal = 0
    xlsLocked = 64
    xlsHidden = 128
End Enum


'set up variables to hold the spreadsheet's layout
Public Enum MarginTypes
   xlsLeftMargin = 38
   xlsRightMargin = 39
   xlsTopMargin = 40
   xlsBottomMargin = 41
End Enum


Public Enum FontFormatting
   'add these enums together. For example: xlsBold + xlsUnderline
   xlsNoFormat = 0
   xlsBold = 1
   xlsItalic = 2
   xlsUnderline = 4
   xlsStrikeout = 8
End Enum


Private Type FONT_RECORD
   opcode As Integer  '49
   length As Integer  '5+len(fontname)
   FontHeight As Integer
   
   'bit0 bold, bit1 italic, bit2 underline, bit3 strikeout, bit4-7 reserved
   FontAttributes1 As Byte
   
   FontAttributes2 As Byte  'reserved - always 0
   
   FontNameLength As Byte
End Type


Private Type PASSWORD_RECORD
   opcode As Integer  '47
   length As Integer  'len(password)
End Type


Private Type HEADER_FOOTER_RECORD
   opcode As Integer  '20 Header, 21 Footer
   length As Integer  '1+len(text)
   TextLength As Byte
End Type


Private Type PROTECT_SPREADSHEET_RECORD
   opcode As Integer  '18
   length As Integer  '2
   Protect As Integer
End Type

Private Type COLWIDTH_RECORD
   opcode As Integer  '36
   length As Integer  '4
   col1 As Byte       'first column
   col2 As Byte       'last column
   ColumnWidth As Integer   'at 1/256th of a character
End Type

'Beginning Of File record
Private Type BEG_FILE_RECORD
  opcode As Integer
  length As Integer
  version As Integer
  ftype As Integer
End Type

'End Of File record
Private Type END_FILE_RECORD
  opcode As Integer
  length As Integer
End Type

'true/false to print gridlines
Private Type PRINT_GRIDLINES_RECORD
  opcode As Integer
  length As Integer
  PrintFlag As Integer
End Type

'Integer record
Private Type tInteger
  opcode As Integer
  length As Integer
  Row As Integer     'unsigned integer
  Col As Integer
 
  'rgbAttr1 handles whether cell is hidden and/or locked
  rgbAttr1 As Byte
 
  'rgbAttr2 handles the Font# and Formatting assigned to this cell
  rgbAttr2 As Byte
 
  'rgbAttr3 handles the Cell Alignment/borders/shading
  rgbAttr3 As Byte
 
  intValue As Integer  'the actual integer value
End Type

'Number record
Private Type tNumber
  opcode As Integer
  length As Integer
  Row As Integer
  Col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  NumberValue As Double  '8 Bytes
End Type

'Label (Text) record
Private Type tText
  opcode As Integer
  length As Integer
  Row As Integer
  Col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  TextLength As Byte
End Type

Private Type MARGIN_RECORD_LAYOUT
  opcode As Integer
  length As Integer
  MarginValue As Double  '8 bytes
End Type


Dim FileNumber As Integer
Dim BEG_FILE_MARKER As BEG_FILE_RECORD
Dim END_FILE_MARKER As END_FILE_RECORD



Public Function CreateFile(ByVal FileName As String) As Integer

On Error GoTo Write_Error

    If Dir$(FileName) > "" Then
       Kill FileName
    End If
   
    FileNumber = FreeFile
    Open FileName For Binary As #FileNumber
    Put #FileNumber, , BEG_FILE_MARKER  'must always be written first
   
    OpenFile = 0  'return with no error
   
Exit Function

Write_Error:
    OpenFile = Err.Number
    Exit Function

End Function

Public Function CloseFile() As Integer

On Error GoTo Write_Error

    Put #FileNumber, , END_FILE_MARKER
    Close #FileNumber
    FileNumber = 0
    CloseFile = 0  'return with no error code
   
Exit Function

Write_Error:
    CloseFile = Err.Number
    Exit Function

End Function


Private Sub Class_Initialize()

'Set up default values for records
'These should be the values that are the same for every record of these types
   
    With BEG_FILE_MARKER  'beginning of file
        .opcode = 9
        .length = 4
        .version = 2
        .ftype = 10
    End With
   
    With END_FILE_MARKER  'end of file marker
        .opcode = 10
    End With
   
   
End Sub


Public Function WriteValue(ValueType As ValueTypes, CellFontUsed As CellFont, Alignment As CellAlignment, HiddenLocked As CellHiddenLocked, lrow As Long, lcol As Long, Value As Variant) As Integer

On Error GoTo Write_Error

'the row and column values are written to the excel file as
'unsigned integers. Therefore, must convert the longs to integer.
    If lrow > 32767 Then
       Row% = CInt(lrow - 65535) - 1  'rows/cols in Excel binary file are zero based
    Else
       Row% = CInt(lrow) - 1
    End If
   
    If lcol > 32767 Then
       Col% = CInt(lcol - 65535) - 1  'rows/cols in Excel binary file are zero based
    Else
       Col% = CInt(lcol) - 1
    End If

   
    Select Case ValueType
      Case ValueTypes.xlsInteger
         Dim INTEGER_RECORD As tInteger
         With INTEGER_RECORD
           .opcode = 2
           .length = 9
           .Row = Row%
           .Col = Col%
           .rgbAttr1 = CByte(HiddenLocked)
           .rgbAttr2 = CByte(CellFontUsed)
           .rgbAttr3 = CByte(Alignment)
           .intValue = CInt(Value)
         End With
         Put #FileNumber, , INTEGER_RECORD
   
   
      Case ValueTypes.xlsNumber
         Dim NUMBER_RECORD As tNumber
         With NUMBER_RECORD
           .opcode = 3
           .length = 15
           .Row = Row%
           .Col = Col%
           .rgbAttr1 = CByte(HiddenLocked)
           .rgbAttr2 = CByte(CellFontUsed)
           .rgbAttr3 = CByte(Alignment)
           .NumberValue = CDbl(Value)
         End With
         Put #FileNumber, , NUMBER_RECORD
     
     
      Case ValueTypes.xlsText
         Dim b As Byte
         st$ = CStr(Value)
         l% = Len(st$)
       
        Dim TEXT_RECORD As tText
        With TEXT_RECORD
          .opcode = 4
          .length = 10
          'Length of the text portion of the record
          .TextLength = IIf(l% > 255, 255, l%)
       
          'Total length of the record
          .length = 8 + l
       
          .Row = Row%
          .Col = Col%
         
          .rgbAttr1 = CByte(HiddenLocked)
          .rgbAttr2 = CByte(CellFontUsed)
          .rgbAttr3 = CByte(Alignment)
       
          'Put record header
          Put #FileNumber, , TEXT_RECORD
       
          'Then the actual string data
          For a = 1 To l%
             b = Asc(Mid$(st$, a, 1))
             Put #FileNumber, , b
          Next
        End With
     
    End Select
   
    WriteValue = 0   'return with no error
   
Exit Function

Write_Error:
    WriteValue = Err.Number
    Exit Function

End Function


Public Function SetMargin(Margin As MarginTypes, MarginValue As Double) As Integer

On Error GoTo Write_Error

    'write the spreadsheet's layout information (in inches)
    Dim MarginRecord As MARGIN_RECORD_LAYOUT
   
    With MarginRecord
      .opcode = Margin
      .length = 8
      .MarginValue = MarginValue 'in inches
    End With
    Put #FileNumber, , MarginRecord

    SetMargin = 0
   
Exit Function

Write_Error:
    SetMargin = Err.Number
    Exit Function

End Function


Public Function SetColumnWidth(FirstColumn As Byte, LastColumn As Byte, WidthValue As Integer)

On Error GoTo Write_Error

    Dim COLWIDTH As COLWIDTH_RECORD
   
    With COLWIDTH
      .opcode = 36
      .length = 4
      .col1 = FirstColumn - 1
      .col2 = LastColumn - 1
      .ColumnWidth = WidthValue * 256  'values are specified as 1/256 of a character
    End With
    Put #FileNumber, , COLWIDTH

    SetColumnWidth = 0
   
Exit Function

Write_Error:
    SetColumnWidth = Err.Number
    Exit Function

End Function


Public Function SetFont(FontName As String, FontHeight As Integer, FontFormat As FontFormatting) As Integer

On Error GoTo Write_Error

    'you can set up to 4 fonts in the spreadsheet file. When writing a value such
    'as a Text or Number you can specify one of the 4 fonts (numbered 0 to 3)
   
    Dim FONTNAME_RECORD As FONT_RECORD
   
    l% = Len(FontName)
   
    With FONTNAME_RECORD
      .opcode = 49
      .length = 5 + l%
      .FontHeight = FontHeight * 20
      .FontAttributes1 = CByte(FontFormat)  'bold/underline etc...
      .FontAttributes2 = CByte(0) 'reserved-always zero!!
      .FontNameLength = CByte(Len(FontName))
    End With
    Put #FileNumber, , FONTNAME_RECORD

    'Then the actual font name data
    Dim b As Byte
    For a = 1 To l%
       b = Asc(Mid$(FontName, a, 1))
       Put #FileNumber, , b
    Next

    SetFont = 0
   
Exit Function

Write_Error:
    SetFont = Err.Number
    Exit Function


End Function


Public Function SetHeader(HeaderText As String) As Integer

On Error GoTo Write_Error

    Dim HEADER_RECORD As HEADER_FOOTER_RECORD
   
    l% = Len(HeaderText)
   
    With HEADER_RECORD
      .opcode = 20
      .length = 1 + l%
      .TextLength = CByte(Len(HeaderText))
    End With
    Put #FileNumber, , HEADER_RECORD

    'Then the actual Header text
    Dim b As Byte
    For a = 1 To l%
       b = Asc(Mid$(HeaderText, a, 1))
       Put #FileNumber, , b
    Next

    SetHeader = 0
   
Exit Function

Write_Error:
    SetHeader = Err.Number
    Exit Function

End Function



Public Function SetFooter(FooterText As String) As Integer

On Error GoTo Write_Error

    Dim FOOTER_RECORD As HEADER_FOOTER_RECORD
   
    l% = Len(FooterText)
   
    With FOOTER_RECORD
      .opcode = 21
      .length = 1 + l%
      .TextLength = CByte(Len(FooterText))
    End With
    Put #FileNumber, , FOOTER_RECORD

    'Then the actual Header text
    Dim b As Byte
    For a = 1 To l%
       b = Asc(Mid$(FooterText, a, 1))
       Put #FileNumber, , b
    Next

    SetFooter = 0
   
Exit Function

Write_Error:
    SetFooter = Err.Number
    Exit Function

End Function



Public Function SetFilePassword(PasswordText As String) As Integer

On Error GoTo Write_Error

    Dim FILE_PASSWORD_RECORD As PASSWORD_RECORD
   
    l% = Len(PasswordText)
   
    With FILE_PASSWORD_RECORD
      .opcode = 47
      .length = l%
    End With
    Put #FileNumber, , FILE_PASSWORD_RECORD

    'Then the actual Password text
    Dim b As Byte
    For a = 1 To l%
       b = Asc(Mid$(PasswordText, a, 1))
       Put #FileNumber, , b
    Next

    SetFilePassword = 0
   
Exit Function

Write_Error:
    SetFilePassword = Err.Number
    Exit Function

End Function




Public Property Let PrintGridLines(ByVal NewValue As Boolean)

On Error GoTo Write_Error

    Dim GRIDLINES_RECORD As PRINT_GRIDLINES_RECORD
   
    With GRIDLINES_RECORD
      .opcode = 43
      .length = 2
      If NewValue = True Then
        .PrintFlag = 1
      Else
        .PrintFlag = 0
      End If
     
    End With
    Put #FileNumber, , GRIDLINES_RECORD

Exit Property

Write_Error:
    Exit Property

 
End Property




Public Property Let ProtectSpreadsheet(ByVal NewValue As Boolean)

On Error GoTo Write_Error

    Dim PROTECT_RECORD As PROTECT_SPREADSHEET_RECORD
   
    With PROTECT_RECORD
      .opcode = 18
      .length = 2
      If NewValue = True Then
        .Protect = 1
      Else
        .Protect = 0
      End If
     
    End With
    Put #FileNumber, , PROTECT_RECORD

Exit Property

Write_Error:
    Exit Property

 
End Property


Private Sub Class_Terminate()

'if the file is still open when we terminate the class then make sure
'we close it. This is for safety reasons.
If FileNumber > 0 Then
  Call Me.CloseFile
End If

End Sub


0
 
LVL 4

Expert Comment

by:ark4877
ID: 11087687
Hi ,
   You can use MSFlexgrid to first display the data and then from flexgrid you can easily export data into excel file.Here is the script.

Dim grid As MSHFlexGrid
Dim xlapp As New Excel.Application
Dim wbxl As Excel.Workbook
Dim wsxl As Excel.Worksheet
Dim introw As Integer 'counter
Dim intcol As Integer 'counter


Public Sub exporttoexcel(ByVal grid As MSFlexGrid)
ec:
    On Error GoTo errh
    If Not IsObject(xlapp) Then
        MsgBox "You need Microsoft Excel to use this function", _
            vbExclamation, "Print to Excel"
        Exit Sub
    End If

    On Error Resume Next

    'Open Excel
  Me.MousePointer = 11
  With grid
    Set xlapp = CreateObject("Excel.Application")
    xlapp.Visible = False
    xlapp.WindowState = xlMaximized
    'xlapp.Workbooks.Add
    Set wbxl = xlapp.Workbooks.Add
    Set wsxl = xlapp.ActiveSheet

    'Fill spreadsheet

    For introw = 1 To .Rows
        For intcol = 1 To .Cols
            wsxl.Cells(introw, intcol).NumberFormat = "General"
            wsxl.Cells(introw, intcol).Value = .TextMatrix(introw - 1, intcol - 1) & " "

        Next
    Next
   End With
    xlapp.Visible = True
 Me.MousePointer = 0
errh:                          'in case of error, informing the user
    If Err.Description <> vbNullString Then
        MsgBox Err.Description
        Me.MousePointer = 0
        Me.dcmbDP = ""
    End If
End Sub

Let me know if it works or not
ARK
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 18

Expert Comment

by:Dennis Aries
ID: 11087757
True, but this MSFlexgrid-solution only works if Excel is installed on the same system. The forementioned class will create a file on disk, allowing you to export to excel, even when you are not using any Office-application.

BTW, a few minor changes to your code:
You define:
* Dim xlApp as NEW Excel.Application

And later on, you:
* Set xlApp = CreateObject("Excel.Application")

In this case, you create two instances of Excel. It would be better to define:
* Dim xlApp as Object
and put the error-handler around the CreateObject.

Futhermore, instead of creating the Excel-object and hiding it, you can also hide the workbook and use a possibly existing Excel-object (in case the user has already started Excel). For example (BTW, I use objects to have a complete late-binding-effect, allowing me to work with possible changes Microsoft may intend):

Dim xlApp as Object
Dim wbxl as Object
On Error Resume Next

Set xlApp = GetObject(Class:="Excel.Application")
If Err.Number <> 0 Then
  Err.Clear
  set xlApp = CreateObject("Excel.Application")
  If Err.Number<>0 Then
    MsgBox("Unable to start Excel")
    Err.Clear
    'Exit subroutine here
    Exit Sub
  End If
End If
'At this point, Excel has been created for sure, we can use it now.
 
Set wbxl = xlapp.Workbooks.Add
wbxl.Visible = False
'Continue any work you want to do here
'...

wbxl.Visible = True

In the end, it all depends on the fact wether:
1. The intented user wil have Excel-installed
2. You want to add formatting to the cells (or even include formula's)
3. You want early or late-binding for your application.

Hope this is clear (and helps :)
Dennis
0
 
LVL 2

Expert Comment

by:harveykane
ID: 11094658
Sorry if this is off topic, but for any Delphi users wanting to do the same thing, the TMS component pack has a lot of components for exporting to excel.
It's not free, but I'm very happy with the stack of components you get for the price.
www.tmssoftware.com
0
 

Expert Comment

by:MB999
ID: 11122175
Here you...simple but effective

'-----Code starts here ----------------------

Private Sub CreateExcelFile()
    Dim fs As New FileSystemObject
    Dim oText As TextStream
    Dim sFileName As String
    Dim stmp As String
   
'Reference: Microsoft Scripting runtime library

On Error GoTo errh

        sFileName = Left(App.Path, 3) & "MyX.xls"
        Set oText = fs.CreateTextFile(sFileName, True)
        If Not oText Is Nothing Then
            stmp = "Month" & vbTab & "Price" & vbTab & "No.of Cards"
            oText.WriteLine stmp
            stmp = "Jan" & vbTab & "45" & vbTab & "18"
            oText.WriteLine stmp
            stmp = "Feb" & vbTab & "90" & vbTab & "9"
            oText.WriteLine stmp
            stmp = "March" & vbTab & "63" & vbTab & "45"
            oText.WriteLine stmp
            oText.Close
            Set oText = Nothing
            MsgBox sFileName & " was created sucessfully", vbInformation
        Else
            MsgBox "Unable to create the file"
        End If
        Exit Sub
errh:
    MsgBox Err.Description
End Sub






'-----Code ends here-------------------------------
0
 
LVL 3

Expert Comment

by:harsha_dp
ID: 11343020
If u r SAS user , you have a very good and easiest solution for this problem.
data t1;
  cards ;
     your data cards
  ;
run;

proc export data=t1 outfile="physical file name"; run;

I think u r not using SAS.
If u can transfer it into a Access database that is also a solution , we can just issue query connecting with MSJET database engine to get data from access table and to transfer values to excel sheet. If needed i can give code snipplet
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

This article is meant to give a basic understanding of how to use R Sweave as a way to merge LaTeX and R code seamlessly into one presentable document.
If you’re thinking to yourself “That description sounds a lot like two people doing the work that one could accomplish,” you’re not alone.
Viewers will learn how to properly install Eclipse with the necessary JDK, and will take a look at an introductory Java program. Download Eclipse installation zip file: Extract files from zip file: Download and install JDK 8: Open Eclipse and …
In this fourth video of the Xpdf series, we discuss and demonstrate the PDFinfo utility, which retrieves the contents of a PDF's Info Dictionary, as well as some other information, including the page count. We show how to isolate the page count in a…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now