Solved

VB EXCEL

Posted on 2004-08-26
11
173 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
11 Comments
 

Expert Comment

by:Keyboard
Comment Utility
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
Comment Utility
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
Comment Utility
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
 
LVL 8

Expert Comment

by:plq
Comment Utility
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
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Author Comment

by:Sara_j_11
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
PAQed with points refunded (500)

modulo
Community Support Moderator
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…

763 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

8 Experts available now in Live!

Get 1:1 Help Now