Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

VB EXCEL

Posted on 2004-08-26
11
Medium Priority
?
239 Views
Last Modified: 2008-01-09
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
Comment
Question by:Sara_j_11
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
11 Comments
 

Expert Comment

by:Keyboard
ID: 11908061
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
 
LVL 10

Expert Comment

by:anv
ID: 11909822
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
 
LVL 10

Expert Comment

by:anv
ID: 11909828
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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
LVL 8

Expert Comment

by:plq
ID: 11910388
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
 

Author Comment

by:Sara_j_11
ID: 11917810
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
 
LVL 10

Expert Comment

by:anv
ID: 11919384
why r u saving the data first to csv and then to .xls..

y dont u directly save it to xls??
0
 

Author Comment

by:Sara_j_11
ID: 11942996
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
 

Author Comment

by:Sara_j_11
ID: 12524873
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
 

Accepted Solution

by:
modulo earned 0 total points
ID: 12848581
PAQed with points refunded (500)

modulo
Community Support Moderator
0

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses

618 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