แปลงข้อมูล Access ไปสร้างเป็น Excel

' http://www.pantip.com/tech/developer/topic/DD1870904/DD1870904.html
' convert Access to Excel
'
Dim strAppPath As String
strAppPath = "c:\test.xls"
'Dim xlApp As Excel.Application
'Dim xlBook As Excel.Workbook
'Dim Sheet As Excel.WorkSheet
Dim xlbook As Object
Dim xlApp As Object
Dim Sheet As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Workbooks.Add
xlApp.Visible = False
'Set xlBook = xlApp.Workbooks.Add
Set Sheet = xlApp.ActiveWorkbook.Sheets(1)
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsstr As String
Set db = CurrentDb
rsstr = "SELECT Table1.Bucket_Data, sorting([Bucket_Data]) AS Expr1, Sum(Table1.Amt) AS SumOfAmt, Table1.ProductType, Table1.Cycle FROM Table1 GROUP BY Table1.Bucket_Data, sorting([Bucket_Data]), Table1.ProductType, Table1.Cycle ORDER BY sorting([Bucket_Data])"
Set rs = db.OpenRecordset(rsstr)

Dim ConnString2 As String
ConnString2 = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=d:\db1.mdb"
Dim cnn2 As New ADODB.Connection
If cnn2.State = 0 Then
cnn2.Open ConnString2
End If
Dim sqlstring As String
Dim rst As New ADODB.Recordset
Dim cntmax As Double
sqlstring = "SELECT Count(*) AS Expr1, Sum(Table1.Amt) AS SumOfAmt, Table1.ProductType, Table1.Cycle FROM Table1 GROUP BY Table1.Bucket_Data, Table1.ProductType, Table1.Cycle"
Set rst = cnn2.Execute(sqlstring)
Dim i As Long
i = 0
rst.MoveFirst
Do While Not rst.EOF
i = i + 1
rst.MoveNext
Loop
Dim x As Long
Dim y As Long
Dim dMax As String
dMax = DCount("[Bucket_Data]", "Table1")

If Not rs.EOF Then
rs.MoveFirst
'Make Excel visible
xlApp.Visible = False 'True
Sheet.Cells(1, 1).Value = "Test Export database from Table1"
'Sheet.Cells(2, 1).Value = "ระหว่างวันที่" & " " & Me.DteFrm(2) & "-" & Me.DteFrm(0) & "-" & Me.DteFrm(1) & " " & "ถึง" & " " & Me.DteFrm(5) & "-" & Me.DteFrm(3) & "-" & Me.DteFrm(4)
Sheet.Cells(1, 1).Font.Name = "Times New Roman"
Sheet.Cells(1, 1).Font.Size = 11
Sheet.Cells(1, 1).Font.Bold = True
'Sheet.Cells(2, 1).HorizontalAlignment = xlCenter
x = 2
'Sheet.Cells(3, 1).Value = "NO."
'Sheet.Cells(3, 1).HorizontalAlignment = xlCenter
Sheet.Cells(x, 1).Value = "Bucket_Data"
Sheet.Cells(x, 1).HorizontalAlignment = xlCenter
Sheet.Cells(x, 2).Value = "Data_Date"
Sheet.Cells(x, 2).HorizontalAlignment = xlCenter
Sheet.Cells(x, 3).Value = "Amt"
Sheet.Cells(x, 3).HorizontalAlignment = xlCenter
Sheet.Cells(x, 4).Value = "ProductType"
Sheet.Cells(x, 4).HorizontalAlignment = xlCenter
Sheet.Cells(x, 5).Value = "Cycle"
Sheet.Cells(x, 5).HorizontalAlignment = xlCenter
x = 2
y = 0
'Dim z As String
rs.MoveFirst
Do While Not rs.EOF
x = x + 1
y = y + 1
'If y < 1 Then
'z = "? "
'Else
'z = y
'End If
'Sheet.Cells(x, 1).Value = z
'Sheet.Cells(x, 1).HorizontalAlignment = xlCenter
'Sheet.Cells(x, 2).Value = rst!Cntx
'Sheet.Cells(x, 2).HorizontalAlignment = xlCenter
Sheet.Cells(x, 1).Value = rs!Bucket_Data
Sheet.Cells(x, 1).HorizontalAlignment = xlCenter
'Sheet.Cells(x, 2).Value = rs!Data_Date
'Sheet.Cells(x, 2).HorizontalAlignment = xlCenter
Sheet.Cells(x, 3).Value = rs!SumOfAmt
Sheet.Cells(x, 3).HorizontalAlignment = xlCenter
Sheet.Cells(x, 4).Value = rs!ProductType
Sheet.Cells(x, 4).HorizontalAlignment = xlCenter
Sheet.Cells(x, 5).Value = rs!Cycle
Sheet.Cells(x, 5).HorizontalAlignment = xlCenter
rs.MoveNext
Me.ActiveXCtl5.Value = (y / i) * 100
Me.cnt = Format((y / i) * 100, "standard") & "%" & " " & y & " " & "Of" & " " & i & " " & "Rec(s)"
'Me.Rec = y & " " & "Of" & " " & dmax & " " & "Rec(s)"
Me.Repaint
Loop
End If
' xlApp.ActiveWorkbook.Saved = True
If Dir(strAppPath) <> "" Then
Kill (strAppPath)
End If
If Dir("D:\my document_c\*.xls") <> "" Then
Kill ("D:\my document_c\*.xls")
End If
'xlApp.ActiveWorkbook.SaveAs FileName:=[Forms]![form1]![Text10], FileFormat:=xlNormal, _
'Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
'CreateBackup:=False
xlApp.ActiveWorkbook.SaveAs FileName:=strAppPath, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
xlApp.Quit
Set xlApp = Nothing
Set Sheet = Nothing
Set xlbook = Nothing

+ ผู้สนับสนุน + รับผู้สนับสนุน