Gộp các file có nhiều sheets

[ngochieu258]

Dear anh chị.
Em đang phải tổng hợp các file của nhiều người, trong các file có nhiều sheet có nội dung và cấu trúc giống nhau. Nhờ các anh chị hỗ trợ em code để gộp các file này vào với nhau. Ví dụ có file điểm của 2 lớp, em cần gộp các sheet "Tong diem", "Mon 1", "Mon 2", "Mon 3", "Mon 4" vào thành 1 file TH.
Anh/chị giúp em với ạ. Em cảm ơn

 

[ngochieu258]

up ạ

 

[snow25]

Dear anh chị.
Em đang phải tổng hợp các file của nhiều người, trong các file có nhiều sheet có nội dung và cấu trúc giống nhau. Nhờ các anh chị hỗ trợ em code để gộp các file này vào với nhau. Ví dụ có file điểm của 2 lớp, em cần gộp các sheet "Tong diem", "Mon 1", "Mon 2", "Mon 3", "Mon 4" vào thành 1 file TH.
Anh/chị giúp em với ạ. Em cảm ơn

Dữ liệu thực tế có môn 5 không bạn.

 

[ngochieu258]

Dữ liệu thực tế có môn 5 không bạn.

Dạ có ạ. Thực tế có thế thêm các môn khác nữa ạ

 

[snow25]

Dạ có ạ. Thực tế có thế thêm các môn khác nữa ạ

Vậy bạn phải đưa file thực tế lên hoặc là những sheets nào không cần copy thì mới có khả năng viết được code nhé.

 

[ngochieu258]

Em đưa sheet "Tham chieu" và "Tham Chieu 2" lên trên đầu và cần gộp các sheets bắt đầu từ sheet "Tong Diem" đến hết thì có viết được không ạ? Em gửi lại file ví dụ ạ

 

[snow25]

Em đưa sheet "Tham chieu" và "Tham Chieu 2" lên trên đầu và cần gộp các sheets bắt đầu từ sheet "Tong Diem" đến hết thì có viết được không ạ? Em gửi lại file ví dụ ạ

Bạn thử.

Sub tonghopdulieu()
    Const tenshet = "#du lieu 1#du lieu 2#Tham chieu#tham chieu 2#" 'can them sheet nào không tông hop vào dây
    Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sql As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 100)
     Dim sarr, j As Long, b As Long, sh As Worksheet, a As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
     ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
     If Not .Show = -1 Then Exit Sub
     For Each sh In ThisWorkbook.Worksheets
         If InStr(1, tenshet, "#" & sh.Name & "#", vbTextCompare) = 0 Then
            a = a + 1
            arr(a) = sh.Name
         End If
     Next
    For Each k In .SelectedItems
        cn.Open (Pro & k & ext)
        For i = 1 To a
            If arr(i) = "Tong Diem" Then
               sql = "Select * From [" & arr(i) & "$B10:E1000]"
               rst.Open sql, cn, 3, 1
              lr = Sheets(arr(i)).Range("B" & Rows.Count).End(xlUp).Row + 1
               Sheets(arr(i)).Range("B" & lr).CopyFromRecordset rst
               rst.Close
            Else
               sql = "Select * From [" & arr(i) & "$B1:E1000]"
               Debug.Print sql
               rst.Open sql, cn, 3, 1
               lr = Sheets(arr(i)).Range("B" & Rows.Count).End(xlUp).Row + 1
               Sheets(arr(i)).Range("B" & lr).CopyFromRecordset rst
               rst.Close
            End If
        Next i
      cn.Close
    Next k
 End With
End Sub

 

[phulien1902]

@snow25:
Bài toán này tôi thấy ứng dụng trong thực tế rất nhiều, tuy nhiên tôi lại chưa biết gì về SQL. Vì vậy bạn có thể giúp tôi sửa lại Code trên với phiên bản Office 2003( cơ quan). Xin cảm ơn!

 

[kokano90]

@snow25:
Bài toán này tôi thấy ứng dụng trong thực tế rất nhiều, tuy nhiên tôi lại chưa biết gì về SQL. Vì vậy bạn có thể giúp tôi sửa lại Code trên với phiên bản Office 2003( cơ quan). Xin cảm ơn!

Em cũng thấy cái này có thể ứng dụng vào rất nhiều vào công việc của nhiều lĩnh vực. Xin phép cho em sử dụng xương code của anh @snow25 để ứng dụng vào công việc của mình. Trong quá trình sử dụng. nếu có vấn đề gì. Nhờ anh hướng dẫn thêm ạ

 

[ngochieu258]

Bạn thử.

Sub tonghopdulieu()
    Const tenshet = "#du lieu 1#du lieu 2#Tham chieu#tham chieu 2#" 'can them sheet nào không tông hop vào dây
    Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sql As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 100)
     Dim sarr, j As Long, b As Long, sh As Worksheet, a As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
     ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
     If Not .Show = -1 Then Exit Sub
     For Each sh In ThisWorkbook.Worksheets
         If InStr(1, tenshet, "#" & sh.Name & "#", vbTextCompare) = 0 Then
            a = a + 1
            arr(a) = sh.Name
         End If
     Next
    For Each k In .SelectedItems
        cn.Open (Pro & k & ext)
        For i = 1 To a
            If arr(i) = "Tong Diem" Then
               sql = "Select * From [" & arr(i) & "$B10:E1000]"
               rst.Open sql, cn, 3, 1
              lr = Sheets(arr(i)).Range("B" & Rows.Count).End(xlUp).Row + 1
               Sheets(arr(i)).Range("B" & lr).CopyFromRecordset rst
               rst.Close
            Else
               sql = "Select * From [" & arr(i) & "$B1:E1000]"
               Debug.Print sql
               rst.Open sql, cn, 3, 1
               lr = Sheets(arr(i)).Range("B" & Rows.Count).End(xlUp).Row + 1
               Sheets(arr(i)).Range("B" & lr).CopyFromRecordset rst
               rst.Close
            End If
        Next i
      cn.Close
    Next k
End With
End Sub

Em cảm ơn anh rất nhiều ạ