• 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
User avatar
truongphu
VIP
VIP
Posts: 4765
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 519 times

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

Postby truongphu » Thu 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:
Attachments
Export Recordset to Excel.rar
(8.91 KiB) Downloaded 997 times


o0o--truongphu--o0o

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

User avatar
vietteiv
Quản trị
Quản trị
Posts: 1323
Joined: Sat 10/02/2007 12:17 am
Location: 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 times
Been thanked: 71 times
Contact:

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

Postby vietteiv » Thu 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) Viewed 7244 times

pc nhà dùng excel 2010

User avatar
truongphu
VIP
VIP
Posts: 4765
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 519 times

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

Postby truongphu » Fri 07/01/2011 7:40 am

vietteiv wrote: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 wrote: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

User avatar
truongphu
VIP
VIP
Posts: 4765
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 519 times

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

Postby truongphu » Fri 07/01/2011 2:17 pm

truongphu wrote: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.  
Attachments
Export recordset to excel by for next.rar
(9.75 KiB) Downloaded 1017 times
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ổ
Posts: 60
Joined: Thu 18/09/2008 1:26 pm
Has thanked: 1 time

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

Postby kysudat » Thu 24/02/2011 3:58 pm

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

User avatar
truongphu
VIP
VIP
Posts: 4765
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 519 times

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

Postby truongphu » Wed 29/08/2012 8:13 am

truongphu wrote: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

User avatar
truongphu
VIP
VIP
Posts: 4765
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 519 times

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

Postby truongphu » Wed 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? :>
Attachments
TRANSFORM SUM GROUP BY PIVOT.rar
(15.96 KiB) Downloaded 351 times
o0o--truongphu--o0o

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

thinh18tt
Mạnh Thường Quân
Mạnh Thường Quân
Posts: 167
Joined: Tue 18/05/2010 11:49 pm
Has thanked: 7 times

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

Postby thinh18tt » Thu 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)

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


Return to “[VB] Mẹo vặt khác”

Who is online

Users browsing this forum: No registered users and 1 guest