• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

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

Các mẹo vặt linh tinh khác, không thuộc nhóm nào
Hình đại diện của người dùng
truongphu
VIP
VIP
Bài viết: 4756
Ngày tham gia: CN 04/11/2007 10:57 am
Đến từ: Cam Đức, Khánh hòa
Has thanked: 14 time
Been thanked: 509 time

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

Gửi bàigửi bởi truongphu » T.Năm 06/01/2011 6:22 pm

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



  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


Hay không? :>
Project cách dùng:
Tập tin đính kèm
Export Recordset to Excel.rar
(8.91 KiB) Đã tải 897 lần


o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh

Hình đại diện của người dùng
vietteiv
Quản trị
Quản trị
Bài viết: 1318
Ngày tham gia: T.Bảy 10/02/2007 12:17 am
Đến từ: Cung cấp giải pháp quản lý doanh nghiệp, dự án, tư vấn xây dựng
Has thanked: 6 time
Been thanked: 69 time
Liên hệ:

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

Gửi bàigửi bởi vietteiv » T.Năm 06/01/2011 9:07 pm

test bị lỗi nên chưa biết có hay ko nữa :P
1-6-2011 9-05-51 PM.png
1-6-2011 9-05-51 PM.png (5.04 KiB) Đã xem 4240 lần

pc nhà dùng excel 2010

Hình đại diện của người dùng
truongphu
VIP
VIP
Bài viết: 4756
Ngày tham gia: CN 04/11/2007 10:57 am
Đến từ: Cam Đức, Khánh hòa
Has thanked: 14 time
Been thanked: 509 time

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

Gửi bàigửi bởi truongphu » T.Sáu 07/01/2011 7:40 am

vietteiv đã viết: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

vietteiv đã viết:pc nhà dùng excel 2010

chịu khó mần từng record sang row :))
o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh

Hình đại diện của người dùng
truongphu
VIP
VIP
Bài viết: 4756
Ngày tham gia: CN 04/11/2007 10:57 am
Đến từ: Cam Đức, Khánh hòa
Has thanked: 14 time
Been thanked: 509 time

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

Gửi bàigửi bởi truongphu » T.Sáu 07/01/2011 2:17 pm

truongphu đã viết: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:
  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.  
Tập tin đính kèm
Export recordset to excel by for next.rar
(9.75 KiB) Đã tải 886 lần
o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh

kysudat
Thành viên năng nổ
Thành viên năng nổ
Bài viết: 60
Ngày tham gia: T.Năm 18/09/2008 1:26 pm
Has thanked: 1 time

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

Gửi bàigửi bởi kysudat » T.Năm 24/02/2011 3:58 pm

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

Hình đại diện của người dùng
truongphu
VIP
VIP
Bài viết: 4756
Ngày tham gia: CN 04/11/2007 10:57 am
Đến từ: Cam Đức, Khánh hòa
Has thanked: 14 time
Been thanked: 509 time

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

Gửi bàigửi bởi truongphu » T.Tư 29/08/2012 8:13 am

truongphu đã viết: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!

  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


Hay không? :)>-
o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh

Hình đại diện của người dùng
truongphu
VIP
VIP
Bài viết: 4756
Ngày tham gia: CN 04/11/2007 10:57 am
Đến từ: Cam Đức, Khánh hòa
Has thanked: 14 time
Been thanked: 509 time

Recordset sang Word không vòng lặp

Gửi bàigửi bởi truongphu » T.Tư 29/08/2012 8:16 am

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

  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.  


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? :>
Tập tin đính kèm
TRANSFORM SUM GROUP BY PIVOT.rar
(15.96 KiB) Đã tải 260 lần
o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh

thinh18tt
Mạnh Thường Quân
Mạnh Thường Quân
Bài viết: 167
Ngày tham gia: T.Ba 18/05/2010 11:49 pm
Has thanked: 7 time

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

Gửi bàigửi bởi thinh18tt » T.Năm 18/02/2016 10:45 pm

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)

Mã: Chọn hết

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


Quay về “[VB] Mẹo vặt khác”

Đang trực tuyến

Đang xem chuyên mục này: Không có thành viên nào trực tuyến.1 khách