• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 244
  • Last Modified:

VB EXCEL

From  Visual basic 6.0 , I am exceuting a sql query(oracle database) and then I am writing the results of the query to an csv file and then saving it as an excel file.

Private Sub WriteExcelReport1(ByVal sFileName As String)
   'remove_file (sFileName)
     'Create a new instance of Excel
   Dim oExcel As Object
   Dim oBook As Object
   Dim oSheet As Object
   Set oExcel = CreateObject("Excel.Application")
       
   'Open the text file
   Set oBook = oExcel.Workbooks.Open("C:\test.csv")
   
   'Save as Excel workbook and Quit Excel
   oBook.SaveAs "C:\Test1.xls", xlWorkbookNormal
   oExcel.Quit
   
   
End Sub

Now my problem is my excel file

ID      PAT_NAME      type
78906      MILLER        GEN
78906      MILLER        c
77      LEVITEN        NU
77      LEVITEN        A
45      MOODY  CARMEN      S
345      HARDESTY  KALEB      S
123456      PARKER  GABRIELLE      S
74863      PARKER  GABRIELLE      S
            
      
            
            


This is my sample excel file and I need to take these id’s and put each unique id in one worksheet in the workbook. For ex. 78906 should be on one worksheet and the 2 rows of 77 should be on another workshhet, within the same workbook.   Please paste the code for this..
0
Sara_j_11
Asked:
Sara_j_11
1 Solution
 
KeyboardCommented:
How about this :-)

1) Select distinct Ids from Oracle database and save it to Ids.csv file
2) Select the data from Oracle into another file - data.csv.
3) Create a workbook, and then loop through the Ids.csv to create that many Worksheets. Name the worksheets with the Id#. Close Ids.csv
4) Open data.csv and start looping through the data and place them in the correct worksheets that you want - using the Id# as a link to the worksheet name.

0
 
anvCommented:
here it is:

say rs i s the recordset that contains all ur records from the database in ascending order (or any sort order)

oBook i sthe workbook object then

dim id as string
dim i!,j!,k!

k=1
j=0
while not rs.eof
if j=0 then
 id= rs(0)
end if

'if same id the add to same worksheet else
if id=rs(0) then
   set ws = oBook.worksheets(k)
   for i = 1 to columnCountofRS
       oBook.cells(j+1,i).value = rs(i)
  next
else
  id = rs(0)
  k=k+1
   set ws = oBook.worksheets(k)
   for i = 0 to columnCountofRS
       oBook.cells(j,i).value = rs(i)
  next

end if

rs.movenext
j=j+1
wend

hope the above code will solve your problem...

if need any help in code....

let me know
0
 
anvCommented:
the sorting of the Rs is based on the ID field of your database...

after the while loop

add a line to save your file..

just forgot to mention these 2 points
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
plqCommented:
Here's a generic write excel function. Just manipulate the objSheet variable to different sheets to achieve what you need, and take out the cr*p about standard named ranges...

Public Function ExcelDumpData(sTemplateFile As String, _
                                sTargetFileName As String, _
                                sHeading As String, _
                                objLvwOrRs As Variant, _
                                Optional bAutoPrint As Boolean, _
                                Optional bAutoFit As Boolean = True, _
                                Optional bSelectedOnly As Boolean = False) As Boolean
   
    '   Copy the contents of a list view or recordset into a standard template
    '   This code requires the standard excel names:
    '   "Heading", "ColumnHeaders", "StartPosition", "Output info"
    '
   
    On Error GoTo ExcelDumpData_Error:
   
    Dim bLandscape      As Boolean
    Dim sSourcePath     As String
    Dim sSourceFile     As String
    Dim sSourceStub     As String
    Dim sTargetPath     As String
    Dim sTargetFile     As String
    Dim sTargetStub     As String
    Dim lst             As ListItem
    Dim fld             As Object
    Dim col             As ColumnHeader
   
    Dim objExcel        As Object
    Dim objBook         As Object
    Dim objSheet        As Object
    Dim objRange        As Object
   
    Dim lRow            As Long
    Dim lCol            As Long
    Dim iCount          As Integer
    Dim bResult         As Boolean
   
    '   Create an instance of excel
   
    gsContext = "ExcelDump"
    Set objExcel = CreateObject("Excel.Sheet")

    '   Ensure that all workbooks are shut

    'If objExcel.Application.Workbooks.Count > 1 Then
    '    MsgBox "Workbooks are already open in excel, please close them and try again", vbCritical
    '    Set objExcel = Nothing
    '    ExcelDumpData = False
    '    Exit Function
    'End If
   
    '   Show an hourglass
   
    Screen.MousePointer = vbHourglass
   
    '   Get the Directory of the template, and split the target path into path and file
   
    sSourcePath = App.Path & "\reports"
    sSourceFile = sTemplateFile
    If Right$(sSourceFile, 4) <> ".xls" Then
        sSourceFile = sSourceFile & ".xls"
    End If
    sSourceStub = Left$(sSourceFile, Len(sSourceFile) - 4)
    sTargetPath = GetFilePath(sTargetFileName)
    sTargetFile = GetFileName(sTargetFileName)
    If Right$(sTargetFile, 4) <> ".xls" Then
        sTargetFile = sTargetFile & ".xls"
    End If
    sTargetStub = Left$(sTargetFile, Len(sTargetFile) - 4)
   
    '   Open the template
   
    objExcel.Application.Workbooks.open sSourcePath & "\" & sSourceFile, True
   
    '   Delete any old version of the file being created
   
    If FileExists(sTargetFileName) Then
        On Error Resume Next
        Kill sTargetFileName
        On Error GoTo ExcelDumpData_Error:
        If FileExists(sTargetFileName) Then
            MsgBox "Unable to delete an old version of " & sTargetFileName & ". The file shown in excel may be an older extract. Please change the files attributes to ensure you have permission to write to it", vbExclamation
        End If
    End If
   
    '   Save the target as an empty spreadsheet and get a reference to the first sheet
   
    objExcel.Application.Workbooks(sSourceFile).SaveAs sTargetFileName, True
    Set objBook = Nothing
    Set objBook = objExcel.Application.Workbooks(sTargetFile)
    Set objSheet = objBook.Worksheets(1)
   
    '   Set the heading
   
    objSheet.Range("Heading").Value = sHeading
    objSheet.Range("OutputInfo").Value = "Output " & Format(Now, "DD/MM/YY HH:NN")
   
    With objSheet
   
        If TypeOf objLvwOrRs Is ListView Then
       
            '   Enter a loop for each columnheader in the listview
           
            Set objRange = .Range("ColumnHeaders")
            With objRange
                iCount = 1
                For Each col In objLvwOrRs.ColumnHeaders
                    .Cells(1, iCount) = col.Text
                    iCount = iCount + 1
                Next
            End With
           
            '   Enter a loop for each item in the listview
           
            Set objRange = .Range("StartPosition")
            With objRange
                lRow = 1
                For Each lst In objLvwOrRs.ListItems
                    If lst.Selected Or bSelectedOnly = False Then
                        For lCol = 1 To objLvwOrRs.ColumnHeaders.Count
                            If lCol = 1 Then
                                .Cells(lRow, lCol) = lst.Text
                            Else
                                .Cells(lRow, lCol) = lst.SubItems(lCol - 1)
                            End If
                        Next
                        lRow = lRow + 1
                    End If
                Next
            End With
        Else
           
            '   Enter a loop for each field in the recordset
           
            Set objRange = .Range("ColumnHeaders")
            With objRange
                iCount = 1
                For Each fld In objLvwOrRs.Fields
                    .Cells(1, iCount) = NiceName(fld.Name)
                    iCount = iCount + 1
                Next
            End With
           
            '   Enter a loop for each record in the recordset
           
            Set objRange = .Range("StartPosition")
            With objRange
                lRow = 1
                objLvwOrRs.MoveFirst
                Do Until objLvwOrRs.EOF
                    For lCol = 1 To objLvwOrRs.Fields.Count
                        Set fld = objLvwOrRs.Fields(lCol - 1)
                        .Cells(lRow, lCol) = fld.Value
                    Next
                    lRow = lRow + 1
                    objLvwOrRs.MoveNext
                Loop
            End With
        End If
    End With
    If bAutoFit Then
        objSheet.Columns.Autofit
    End If
    If bAutoPrint Then
        objSheet.Printout
    Else
        'MsgBox "File " & sTargetFileName & " has been created. Please open it using Excel.", vbInformation
    End If
    bResult = True
   
ExcelDumpData_Done:
   
    If Not objBook Is Nothing Then
        objBook.Close bResult
        Set objBook = Nothing
    End If
    ExcelDumpData = bResult
   
    Screen.MousePointer = vbDefault
   
    Exit Function
   
ExcelDumpData_Error:
    Select Case Err
        Case Else
            HandleError
    End Select
    ExcelDumpData = False
    Resume ExcelDumpData_Done:
    Resume
   
End Function
0
 
Sara_j_11Author Commented:
The code that 'any' has posted seems to be short , but when I pasted that code in my function:

Private Sub WriteExcelReport1(ByVal sFileName As String)
   'remove_file (sFileName)
     'Create a new instance of Excel
   Dim oExcel As Object
   Dim oBook As Object
   Dim oSheet As Object
   Set oExcel = CreateObject("Excel.Application")
       
   'Open the text file
   Set oBook = oExcel.Workbooks.Open("C:\test.csv")
   
dim id as string
dim i!,j!,k!

k=1
j=0
while not rs.eof
if j=0 then
 id= rs(0)
end if

'if same id the add to same worksheet else
if id=rs(0) then
   set ws = oBook.worksheets(k)
   for i = 1 to columnCountofRS
       oBook.cells(j+1,i).value = rs(i)
  next
else
  id = rs(0)
  k=k+1
   set ws = oBook.worksheets(k)
   for i = 0 to columnCountofRS
       oBook.cells(j,i).value = rs(i)
  next

end if

rs.movenext
j=j+1
wend



   'Save as Excel workbook and Quit Excel
   oBook.SaveAs "C:\Test1.xls", xlWorkbookNormal
   oExcel.Quit
   Set oExcel = Nothing


This just creates the excel file without doing all the seperation into differnet worksheets. Am I missing something....It just saves the csv file as the excel file and that is all it does...  Am i missing some part here? It does not even give an error...
0
 
anvCommented:
why r u saving the data first to csv and then to .xls..

y dont u directly save it to xls??
0
 
Sara_j_11Author Commented:
hi thanks for following up..

It is because I don’t know how to directly save it to excel.. This is how I do it..

sSQL = " "
    sSQL = Build_Query(SQL_Home & "\report.sql")
       
    rstRecordSet.Open sSQL, conn, adOpenForwardOnly
   

     sFileName = sFolderLoc & "\test.csv"
     
     WriteOutReport1 sFileName

 Sub WriteExcelReport1 s sFileName




Private Sub WriteOutReport1(ByVal sFileName As String)
 'remove_file (sFileName)
     
     If rstRecordSet.RecordCount > 0 Then 'put data into file which will be read
     Open sFileName For Output As #1
     
        Write #1, rstRecordSet.Fields(0).Name, rstRecordSet.Fields(1).Name, _
                        rstRecordSet.Fields(2).Name, rstRecordSet.Fields(3).Name, _
                        rstRecordSet.Fields(4).Name, rstRecordSet.Fields(5).Name, _
                        rstRecordSet.Fields(6).Name, rstRecordSet.Fields(7).Name, _
                        rstRecordSet.Fields(8).Name, rstRecordSet.Fields(9).Name, _
                        rstRecordSet.Fields(10).Name, rstRecordSet.Fields(11).Name, _
                        rstRecordSet.Fields(12).Name, rstRecordSet.Fields(13).Name
                       
                       


        Do While Not rstRecordSet.EOF
                    Write #1, rstRecordSet.Fields(0), rstRecordSet.Fields(1), _
                        rstRecordSet.Fields(2), rstRecordSet.Fields(3), _
                        rstRecordSet.Fields(4), rstRecordSet.Fields(5), _
                        rstRecordSet.Fields(6), rstRecordSet.Fields(7), _
                        rstRecordSet.Fields(8), rstRecordSet.Fields(9), _
                        rstRecordSet.Fields(10), rstRecordSet.Fields(11), _
                        rstRecordSet.Fields(12), rstRecordSet.Fields(13)
                       

        rstRecordSet.MoveNext
        Loop

        Close #1

      'rstRecordSet.Close
    End If



Private Sub WriteExcelReport1(ByVal sFileName As String)
'remove_file (sFileName)
'Create a new instance of Excel
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
Set oExcel = CreateObject("Excel.Application")

'Open the text file
Set oBook = oExcel.Workbooks.Open("C:\test.csv")

'Save as Excel workbook and Quit Excel
oBook.SaveAs "C:\Test1.xls", xlWorkbookNormal
oExcel.Quit


End Sub
0
 
Sara_j_11Author Commented:
I am sorry ; I did not notice that this question was timed out.. I am still waiting for the expert to clear my doubt on 08/31/2004 at 8:15. I would like to reopen this question and pl. take back the negative feedback
0
 
moduloCommented:
PAQed with points refunded (500)

modulo
Community Support Moderator
0

Featured Post

Prep for the ITIL® Foundation Certification Exam

December’s Course of the Month is now available! Enroll to learn ITIL® Foundation best practices for delivering IT services effectively and efficiently.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now