* Microsoft Visual Basic 6
* Microsoft SQL Server 2000
* Microsoft Excel 2010
Problem :
1. Want to export data from SQL Server query to Microsoft Excel
2. There is an maximum row of Microsoft Excel, then want to display to another worksheet
Solution :
1. Example Table :
2. Go to menu "Project > References ... "
3. Go to menu "Project > Components ... "
4. Design an Example Form below
5. Copy the below code to "Form1.frm"
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
'----START CODE
Private Sub Command1_Click()
Show_To_Excel
End Sub
Private Function RoundUp(ByVal lngNumber As Long) As Long
Dim lngTemp As Long
If Int(lngNumber) <> lngNumber Then
RoundUp = Int(lngNumber) + 1
Else
RoundUp = lngNumber
End If
End Function
Private Sub Show_To_Excel()
'---------------------------------------------------------------------
'---------------------------------------------------------------------
'---Declare for Microsoft Excel
Dim ExcelApp As Excel.Application
Dim ExcelWorkBook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet
Dim ExcelRange As Excel.Range
'---Declare for Connection
Dim conn_1 As ADODB.Connection
Dim rs_1 As ADODB.Recordset
Dim sql_1 As String
'---Declare for DAO - Microsoft Excel
Dim dbExcel As Database
Dim rsExcel As DAO.Recordset
Dim RowNo As Long
Dim ColNo As Integer
Dim LineNo As Long
Dim counterBar As Integer
Dim i As Integer
Dim WorkSheetNum As Long
Dim MaxExcelRows As Long
Dim TotalWorkSheet As Long
MaxExcelRows = 20
Dim fName As Variant
'---------------------------------------------------------------------
'---------------------------------------------------------------------
'---Creating Connection
Set conn_1 = New ADODB.Connection
conn_1.Open "Provider=sqloledb;Data Source=(local);Initial Catalog=Northwind; User Id=sa; Password=sasasa;"
'---Creating New File Excel
Set ExcelApp = New Excel.Application
fName = ExcelApp.GetSaveAsFilename(, "Excel (*.xls), *.xls", , "Save to Excel")
If fName = False Then Exit Sub
'---Creating Query
Set rs_1 = New ADODB.Recordset
sql_1 = " select * from Products order by ProductID "
rs_1.Open sql_1, conn_1, 1, 1
ProgressBar.Max = rs_1.RecordCount + 1
counterBar = 0
'---------------------------------------------------------------------
'---------------------------------------------------------------------
'---------------------------------------------------------------------
If Not rs_1.EOF Then
counterBar = counterBar + 1
ProgressBar.Value = counterBar
Dim FieldsType2() As ADODB.DataTypeEnum
Dim FieldsCount2 As Integer
Dim TotalRows As Long
FieldsCount2 = rs_1.Fields.Count
ReDim FieldsType2(FieldsCount2 - 1)
For i = 0 To FieldsCount2 - 1
FieldsType2(i) = rs_1.Fields(i).Type
Next i
'---Preparing the worksheet
Set ExcelWorkBook = ExcelApp.Workbooks.Add
ExcelWorkBook.SaveAs fName, xlExcel8
TotalWorkSheet = RoundUp(rs_1.RecordCount / MaxExcelRows)
WorkSheetNum = 1
TotalRows = rs_1.RecordCount
'---Start A - Initialize for Heading Column
Do While WorkSheetNum <= TotalWorkSheet
Set ExcelWorkSheet = ExcelWorkBook.Worksheets.Add
ExcelWorkSheet.Name = "Page_" & Format(TotalWorkSheet - WorkSheetNum + 1, "##0")
RowNo = 1
ColNo = 1
ExcelWorkSheet.Cells(RowNo, ColNo).ColumnWidth = Len("Number")
ExcelWorkSheet.Cells(RowNo, ColNo) = "No"
ExcelWorkSheet.Cells(RowNo, ColNo).HorizontalAlignment = xlLeft
ExcelWorkSheet.Cells(RowNo + 1, ColNo) = ""
For i = 0 To FieldsCount2 - 1
ColNo = ColNo + 1
ExcelWorkSheet.Cells(RowNo, ColNo).ColumnWidth = IIf(Len(rs_1.Fields(i).Name) > 15, Len(rs_1.Fields(i).Name), 15)
ExcelWorkSheet.Cells(RowNo, ColNo) = CStr(rs_1.Fields(i).Name)
If FieldsType2(i) = adDouble Or FieldsType2(i) = adSingle Then
ExcelWorkSheet.Cells(RowNo, ColNo).HorizontalAlignment = xlRight
ExcelWorkSheet.Cells(RowNo, ColNo).NumberFormat = "#, ##0.00;[Red](#, ##0.00);0.00"
ExcelWorkSheet.Cells(RowNo + 1, ColNo) = 0
ElseIf FieldsType2(i) = adVarChar Or FieldsType2(i) = adVarWChar Then
ExcelWorkSheet.Cells(RowNo, ColNo).HorizontalAlignment = xlLeft
ExcelWorkSheet.Cells(RowNo + 1, ColNo) = ""
ElseIf FieldsType2(i) = adDate Or FieldsType2(i) = adDBDate Or FieldsType2(i) = adDBTimeStamp Then
ExcelWorkSheet.Cells(RowNo, ColNo).HorizontalAlignment = xlLeft
ExcelWorkSheet.Cells(RowNo + 1, ColNo) = Date
Else
ExcelWorkSheet.Cells(RowNo, ColNo).HorizontalAlignment = xlRight
ExcelWorkSheet.Cells(RowNo, ColNo).NumberFormat = "###0;[Red](###0);0"
ExcelWorkSheet.Cells(RowNo + 1, ColNo) = 0
End If
Next i
WorkSheetNum = WorkSheetNum + 1
Loop
'---End A - Initialize for Heading Column
ExcelWorkBook.Save
ExcelWorkBook.Close True
ExcelApp.Quit
MsgBox "Generating Heading Column Successfully...."
'-----------------------------------------------------------------
'-----------------------------------------------------------------
'---Start B. Generating the detail of data To File Excel
Set dbExcel = DBEngine.OpenDatabase(fName, True, False, "Excel 8.0;")
WorkSheetNum = 1
'---start Loop - 2
Do While Not rs_1.EOF
Set rsExcel = dbExcel.OpenRecordset(dbExcel.TableDefs(WorkSheetNum - 1).Name)
LineNo = 0
RowNo = 0
'---start Loop - 1
Do While Not rs_1.EOF
counterBar = counterBar + 1
ProgressBar.Value = counterBar
LineNo = LineNo + 1
RowNo = RowNo + 1
If LineNo = 1 Then
rsExcel.Edit
Else
rsExcel.AddNew
End If
For i = 0 To FieldsCount2 - 1
If FieldsType2(i) = adDouble Or FieldsType2(i) = adSingle Then
rsExcel.Fields(i + 1) = Val(rs_1.Fields(i))
ElseIf FieldsType2(i) = adVarChar Or FieldsType2(i) = adVarWChar Then
rsExcel.Fields(i + 1) = Mid(CStr(rs_1.Fields(i)), 1, 255)
ElseIf FieldsType2(i) = adDate Or FieldsType2(i) = adDBDate Or FieldsType2(i) = adDBTimeStamp Then
If IsDate(rs_1.Fields(i)) Then
rsExcel.Fields(i + 1) = CDate(rs_1.Fields(i))
Else
rsExcel.Fields(i + 1) = Null
End If
Else
rsExcel.Fields(i + 1) = Val(rs_1.Fields(i))
End If
Next
rsExcel.Fields("No") = LineNo
rsExcel.Update
'---For progress generating of which Rows
Form1.lblProgress.Caption = "Total Rows = " & TotalRows & " - Progress from Row " & RowNo & " of Worksheet " & WorkSheetNum & " ( Total Worksheets = " & TotalWorkSheet & " ) "
Form1.lblProgress.Refresh
rs_1.MoveNext
If rs_1.EOF Or RowNo = MaxExcelRows Then Exit Do
Loop
'---end Loop - 1
rsExcel.Close
WorkSheetNum = WorkSheetNum + 1
Loop
'---end Loop - 2
dbExcel.Close
'---End B. Generating the detail of data To File Excel
'-----------------------------------------------------------------
'-----------------------------------------------------------------
MsgBox "Generating Detail To Excel Successfully...."
End If
'---------------------------------------------------------------------
'---------------------------------------------------------------------
'---------------------------------------------------------------------
Set ExcelWorkBook = ExcelApp.Workbooks.Open(fName)
ExcelWorkBook.Activate
MsgBox "Done. Click OK, to Preview..."
ExcelApp.Visible = True
rs_1.Close
Set rs_1 = Nothing
Set conn_1 = Nothing
End Sub
Private Sub Form_Load()
End Sub
'----END CODE
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
A.
B.
C.
D.
E.
F.
G.
H.
I.
6. Try to run the code, click "F5" or "Start". Next, click "Show To Excel"
A.
B.
C.
D.
E.
7. Then, the results will display in Microsoft Excel successfully.
Example :
Total Rows = 77
Maximum Row Per Sheet = 20
So, the Total Worksheet is 4.
A.
B.
C.
To download the Example Project, please click the link below :
Example Code - Export To Excel - Many WorkSheet.rar