Chuyển dữ liệu từ Recordset sang Excel

[truongphu]

Thủ thuật: Chuyển dữ liệu từ Recordset sang Excel
Tác giả: truongphu
Mô tả: Nhiều thắc mắc về vấn đề nầy, tôi viết sub RectoExcel tặng các bạn

---

Code: [Select all] [Expand/Collapse] [Download]

1. Sub RectoExcel(Rec As Recordset, FName As String)
2. ''' Add references MS Excel, MS ActiveX Data Objects
3. Dim oExcel As New Excel.Application
4. Dim oBook As Workbook
5. Dim oSheet As Worksheet ' Created by truongphu
6.   Set oBook = oExcel.Workbooks.Add
7.    Set oSheet = oBook.Worksheets(1)
8.    oSheet.Range("A1").CopyFromRecordset Rec
9.    oBook.SaveAs FName
10.    oExcel.Quit: Set oExcel = Nothing
11. End Sub

GeSHi © Codebox Plus

Hay không?
Project cách dùng:

[vietteiv]

test bị lỗi nên chưa biết có hay ko nữa

1-6-2011 9-05-51 PM.png (5.04 KiB) Viewed 7377 times

pc nhà dùng excel 2010

[truongphu]

test bị lỗi

Thấy mới 5 người load, hy vọng 4 người còn lại không lỗi.

cấu hình của tác giả: Excel 2003 (Library 11), ADO 2.8, và XP Windows

pc nhà dùng excel 2010

chịu khó mần từng record sang row

[truongphu]

vietteiv wrote:
pc nhà dùng excel 2010
chịu khó mần từng record sang row

Quà năm mới, đặc biệt:

Code: [Select all] [Expand/Collapse] [Download]

1. Private Sub RecorsetToExcel(ByVal Reco As Recordset, FName As String)
2.     Reco.MoveFirst '  author truongphu
3.    Dim XX: XX = Reco.GetRows
4.     Dim a&: a = UBound(XX, 1):  Dim b&: b = UBound(XX, 2)
5.     Dim oExcel As New Excel.Application
6.     Dim oBook As Workbook
7.     Dim oSheet As Worksheet ' Created by truongphu
8.    Set oBook = oExcel.Workbooks.Add
9.     Set oSheet = oBook.Worksheets(1)
10.     Dim i&, j&
11.     For i = 0 To a 'Header Columns
12.        oSheet.Cells(1, i + 1).Value = Reco.Fields(i).Name
13.         ' format sô' thành string nê'u muô'n
14.        'If Reco.Fields(i).Type = adVarChar Or adChar Then oSheet.Columns(i + 1).NumberFormat = "@"
15.    Next
16.     ' Có 2 cách ghi Data:
17.    Dim YY: ReDim YY(b, a) ' 1- Ghi data kiêu mo'i 1 loat nhanh hon
18.    For i = 0 To b
19.         For j = 0 To a
20.             YY(i, j) = XX(j, i)
21.         Next
22.     Next
23.     oSheet.Range("A2").Resize(b + 1, a + 1).Value = YY
24.        
25.     'For j = 0 To b ' 2- Ghi data theo truyê`n thô'ng tu`ng cell
26.        'For i = 0 To a
27.            'oSheet.Cells(j + 2, i + 1).Value = XX(i, j)
28.        'Next i
29.    'Next j
30.   oBook.SaveAs FName
31.    oExcel.Quit: Set oExcel = Nothing
32. End Sub
33.  

GeSHi © Codebox Plus

[kysudat]

Cám ơn Bác TruongPhu nhe,
Đang cần

[truongphu]

Private Sub RecorsetToExcel(ByVal Reco As Recordset, FName As String)

Khi khai báo As Recordset, đương nhiên ta phải chèn thư viện ADO trước, nếu không sẽ báo lỗi.
Sau đây tôi viết hàm chuyển mới không dùng vòng lặp!

Code: [Select all] [Expand/Collapse] [Download]

1. Private Sub Recorset2Excel(ByVal Re As Recordset, Fpath As String)
2. Dim zExcel As Object: Set zExcel = CreateObject("Excel.Application")
3. Dim zBook As Object: Set zBook = zExcel.Workbooks.Add
4. Dim NRow&: NRow = rs.RecordCount
5. Dim NCol&: NCol = rs.Fields.Count ' Created by truongphu
6.  
7. Clipboard.Clear
8. Dim MM$, i&
9. For i = 0 To NCol - 1 ' ghi tên môi côt
10.    If i < NCol - 1 Then
11.         MM = MM & Re.Fields(i).Name & vbTab
12.     Else
13.         MM = MM & Re.Fields(i).Name & vbCrLf
14.     End If
15. Next
16. Clipboard.SetText MM & Re.GetString(2, , , vbCrLf)
17. zBook.Worksheets(1).Paste
18. zBook.SaveAs Fpath: zBook.Close
19. zExcel.Quit: Set zExcel = Nothing
20. End Sub

GeSHi © Codebox Plus

Hay không?

[truongphu]

(Cần chèn thư viện ADO trước để khai báo ByVal Re As Recordset không bị lỗi)

Code: [Select all] [Expand/Collapse] [Download]

1. Private Sub Recorset2Word(ByVal Re As Recordset, Fpath As String)
2. Dim zWord As Object: Set zWord = CreateObject("Word.Application")
3. Dim zDoc As Object: Set zDoc = zWord.Documents.Add
4. Dim NRow&: NRow = rs.RecordCount + 1 ' thêm tên côt khi create table
5. Dim NCol&: NCol = rs.Fields.Count ' Created by truongphu
6.  
7. Clipboard.Clear
8. Dim MM$, i&
9. For i = 0 To NCol - 1 ' ghi tên môi côt
10.    If i < NCol - 1 Then
11.         MM = MM & Re.Fields(i).Name & vbTab
12.     Else
13.         MM = MM & Re.Fields(i).Name & vbCrLf
14.     End If
15. Next
16. Clipboard.SetText MM & Re.GetString(2, , , vbCrLf)
17.     With zDoc
18.         .Tables.Add Range:=zWord.Selection.Range, NumRows:=NRow, NumColumns:=NCol
19.         .Tables(1).Range.Paste
20.     End With
21. zDoc.SaveAs Fpath: zDoc.Close
22. zWord.Quit: Set zWord = Nothing
23. End Sub
24.  

GeSHi © Codebox Plus

Cách dùng: vd code:
Private Sub Command4_Click()
Recorset2Word rs, App.Path & "\Doc1.doc"
End Sub
mà rs là recordset

Hay không?

[thinh18tt]

Chào bác Phú;
Em góp thêm sub này, em sưu tầm và sửa theo mục đích của em, code khá nhanh. Xuất 10 nghìn dòng và 15 cột mất khoảng 3s (với con HP Probook của em)

Code: Select all

Public Sub RtoE(ByVal sql As String, Optional SheetName As String = "")
    On Error GoTo Err
    Dim Rst As New ADODB.Recordset
    Dim FldCount As Integer
    Dim iCol As Integer
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    Set xlApp = CreateObject("Excel.Application")    'Create an instance of Excel and add a workbook
    If Val(xlApp.Version) > 8 And Val(xlApp.Version) < 15 Then 'EXCEL 2000,2002,2003,2007,2010
        Set xlWb = xlApp.Workbooks.Add
        If sql <> "" Then
            Rst.Open sql, Cn ' Open recordset from Table want to export
            Set xlWs = xlWb.Worksheets(1)
            If SheetName <> "" Then xlWb.ActiveSheet.Name = SheetName
            xlApp.Visible = True
            xlApp.UserControl = True
            FldCount = Rst.Fields.Count 'Copy field names to the first row of the worksheet
            For iCol = 1 To FldCount
                xlWs.Cells(1, iCol).Value = Rst.Fields(iCol - 1).Name
            Next
            xlWs.Cells(2, 1).CopyFromRecordset Rst 'Note: CopyFromRecordset will fail if the recordset contains an OLE object field or array data such as hierarchical recordsets
            Rst.Close
            xlApp.Selection.CurrentRegion.Columns.AutoFit 'Auto-fit the column widths and row heights
            xlApp.Selection.CurrentRegion.Rows.AutoFit
        End If
        Set Rst = Nothing
    Else
        MsgBox "Khong ho tro phien ban Excel dang cai dat."
    End If
End Sub