Dùng ADO để lấy dữ liệu từ nhiều sheet của 1 file đang đóng?

Liên hệ QC
ditimdl

ditimdl

Thành viên thường trực
Tham gia
11/10/06
Bài viết
378
Được thích
107
Giới tính
Nam
Nghề nghiệp
Pharmacist
Gửi các bạn!
Mình có sưu tầm 1 đoạn code của bạn dhn46 trên diễn đàn GPE để lấy dữ liệu từ 1 sheet của file đang đóng và cho vào 1 sheet của file đang mở, code hoạt động tốt. Tuy nhiên, do nhu cầu công việc nên mình muốn lấy dữ liệu nhiều sheet của 1 file đang đóng cho vào nhiều sheet của file đang mở nhưng mình không biết chỉnh sửa thế nào cho đúng.
(Nếu thực hiện code này nhiều lần thì vẫn cho kết quả như mình mong muốn nhưng như vậy sẽ mất nhiều thời gian cho thao tác chọn file để mở)
Mong các bạn giúp đỡ!
Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    Application.ScreenUpdating = False
    'Mo hop thoai chon file
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "DHN46 - Thong bao"
            Exit Sub
        End If
        'Duyet qua cac file duoc chon
        For Each Fname In .SelectedItems
            'Tao ket noi CSDL
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
            End With
            'Cau lenh truy van
            lsSQL = "SELECT * FROM [THONGKE$A1:AJ65536] WHERE f2 is not Null"
            lrs.Open lsSQL, cnn, 3, 1
            'Copy ket qua vao sheet Tong hop
            Sheet2.Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs

            cnn.Close
        Next
    End With
    Application.ScreenUpdating = True
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn dùng vòng lặp xem sau

Mã: 
ShNameNguon = Array("N1", "N2", "N3")
ShNameDich = Array("D1", "D2", "D3")
For i = 0 To UBound(ShNameNguon)
        ................
        ................ 
        'Code ADO 
     With Worksheets(ShNameDich(i))
       .Cells.ClearContents
       .[A1].CopyFromRecordset lrs
     End with
Next
Nói chung cấu trúc có thể là thể
 
Upvote 0
Cám ơn!
Các bạn có thể sửa trực tiếp vào code trên giúp mình được không?
 
Upvote 0
Bạn đưa file giả lập lên xem sau nhưng cũng đúng với thực tế để khỏi sửa code lại nhiều lần
 
Upvote 0
Bạn xem giúp mình. Dữ liệu file nguồn thay đổi hàng ngày/tháng, file đích lấy toàn bộ dữ liệu trong file nguồn để báo cáo.
 

File đính kèm

  • vidu.rar
    72.8 KB · Đọc: 140
Upvote 0
ditimdl đã viết:
Bạn xem giúp mình. Dữ liệu file nguồn thay đổi hàng ngày/tháng, file đích lấy toàn bộ dữ liệu trong file nguồn để báo cáo.
Nhấp chuột vào đây để mở rộng...
Thử code này xem sao
Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("THONGKE", "79aHD", "TH79aHD")
    Application.ScreenUpdating = False
    'Mo hop thoai chon file
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "DHN46 - Thong bao"
            Exit Sub
        End If
        'Duyet qua cac file duoc chon
        For Each Fname In .SelectedItems
            'Tao ket noi CSDL
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
            
            For i = 0 To UBound(shNameNguon)
            'Cau lenh truy van
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A1:AJ65536] WHERE f2 is not Null"
                lrs.Open lsSQL, cnn, 3, 1
            'Copy ket qua vao sheet Tong hop
                Sheets(shNameNguon(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close            
            Next            
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
 
Upvote 0
Có cho ra kết quả nhưng không nhìn chẳng giống ai hic hic. Có thể tùy biến copy từng vùng trong từng sheet (file nguồn) và dán vào từng vùng (file đích) theo ý mình được không bạn?
 
Upvote 0
có vẻ như thực chất là bạn muốn Copy Sheet xxx từ file ngồn sang file dích đúng không nào?, nếu đúng vậy mọi việc cực kỳ đơn giản chẳng cần dùng đến ADO đâu
 
Upvote 0
Mình hỏi thế này nha:
Bạn sẽ có VD 20 file với các tên gần giống nhau, bạn sẽ mở từng file (mở ẩn) sau đó chon sheet (VD sheet1, sheet này phải có ở tất cả các file) và move nó đến file đích để tổng hợp sau sau đó đóng file đó lại lần lượt cho đến khi nào hết, đúng vậy không
(nếu đúng bạn gửi file mấu lên đi mình xử cho)
 
Upvote 0
Trong file làm việc của mình có tầm ~15 sheet, mình muốn xuất ra những sheet (~3 sheet) để làm file báo cáo gửi đi (dạng file điện tử chứ in ra thì k có gì để bàn) với điều kiện là giữ nguyên cấu trúc và tên của sheet.
Bạn nào giúp mình với.
 
Upvote 0
ditimdl đã viết:
Bạn xem giúp mình. Dữ liệu file nguồn thay đổi hàng ngày/tháng, file đích lấy toàn bộ dữ liệu trong file nguồn để báo cáo.
Nhấp chuột vào đây để mở rộng...
Mình gieo quẻ và viết code thế này xem sao. Để test code thì bạn nên dùng 2 cái file này trước. Nếu đúng ý rồi mới tính tiếp
PHP: 
Sub laydulieu()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim sh As Worksheet, CurWB As Workbook, path As String, ShName As String
Set CurWB = ThisWorkbook
path = CurWB.path
With Workbooks.Open(path & "\" & "nguon.xls", UpdateLinks:=0)
    For Each sh In CurWB.Worksheets
        ShName = sh.Name
        sh.Delete
        .Sheets(ShName).Copy after:=CurWB.Sheets(CurWB.Sheets.Count)
    Next
    .Close False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Chưa hiểu thật kỹ yêu cầu của bạn nhưng nếu bạn muốn chuyển dữ liệu nhiều sheet vào các sheet tương ứng file báo cáo thì bạn cho 1 vùng lặp là được

Mã: 
            'Cau lenh truy van
            lsSQL = "SELECT * FROM [[B][COLOR=#ff0000]THONGKE$A1:AJ65536[/COLOR][/B]] WHERE f2 is not Null"
            lrs.Open lsSQL, cnn, 3, 1
            'Copy ket qua vao sheet Tong hop
            [B][COLOR=#006400]Sheet2[/COLOR][/B].Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs

Bạn dùng vòng lặp để thay thế đoạn màu đỏ cho sheet file nguồn, màu xanh cho sheet file đích
 
Upvote 0
quanghai1969 đã viết:
Mình gieo quẻ và viết code thế này xem sao. Để test code thì bạn nên dùng 2 cái file này trước. Nếu đúng ý rồi mới tính tiếp
PHP: 
Sub laydulieu()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim sh As Worksheet, CurWB As Workbook, path As String, ShName As String
Set CurWB = ThisWorkbook
path = CurWB.path
With Workbooks.Open(path & "\" & "nguon.xls", UpdateLinks:=0)
    For Each sh In CurWB.Worksheets
        ShName = sh.Name
        sh.Delete
        .Sheets(ShName).Copy after:=CurWB.Sheets(CurWB.Sheets.Count)
    Next
    .Close False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Vậy nếu coppy vào 1 sheet mình chỉ định sửa code này thế nào hả anh
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
71
Đọc
1K
VetMini
V
P
Nhờ các cao nhân cứu giúp em file excel bị lỗi phần mở rộng
Trả lời
1
Đọc
169
PHNGMINH
P
T
  • Question
Cho mình hỏi tại sao file mình chạy Sao lưu lại bị đầy bộ nhớ.
Trả lời
3
Đọc
98
BuiQuangThuan
B
phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
4
Đọc
71
phammaihuong90
phammaihuong90
O
Kết hợp hàm value
Trả lời
1
Đọc
55
bebo021999
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom