Em cần giúp đỡ về tổng hợp dữ liệu từ nhiều file

[DarKLov3]

E cần tổng hợp dữ liệu từ nhiều file, trong file có nhiều sheet như chủ thớt. E cũng đã mày mò theo các clip của thầy @Nguyễn Duy Tuân, và một số bài trên diễn đàn. tuy nhiên học chưa đâu vào đâu nên ko biết sửa thêm. hic.
Trường hợp của em như sau:
E cần tổng hợp số liệu từ nhiều người trong đơn vị, các file của từng người thì có cấu trúc như nhau gồm 3 sheet trở lên,
File tổng hợp dữ liệu cũng có cùng cấu trúc như vậy. E muốn khi ấn nút tổng hợp dữ liệu thì sẽ tổng hợp từ các file của từng người vào các sheet tương ứng.
Ví dụ: trên File tổng hợp có sheet "Bieu_37", khi tổng hợp thì dữ liệu tại sheet "Bieu_37" của các file con đc đưa về file tổng hợp mà tên của các đơn vị trên bieu 37 la cố định, chỉ cần lấy số từ cột C trở đi tương ứng với từng đơn vị

Rất mong được sự giúp đỡ của các anh chị trên diễn đàn.
E xin chân thành cảm ơn.

 

[DarKLov3]

Sau khi tham khảo nhiều bài thì e có viết dc code tổng hợp cho từng sheet rồi tạo sub gọi từng code lên. Tuy nhiên vấn đề là khi chạy code thì chương trình yêu cầu chọn file lại nhiều lần ( Vì tổng hợp mỗi sheet lại mở file 1 lần.) Liệu có ai giúp e xử lý vấn đề đc không ạ, chỉ mở một lần đầu tiên rồi thực hiện các công việc còn lại cho xong.
e gửi file nhờ mọi người giúp ạ

 

[giaiphap]

Sau khi tham khảo nhiều bài thì e có viết dc code tổng hợp cho từng sheet rồi tạo sub gọi từng code lên. Tuy nhiên vấn đề là khi chạy code thì chương trình yêu cầu chọn file lại nhiều lần ( Vì tổng hợp mỗi sheet lại mở file 1 lần.) Liệu có ai giúp e xử lý vấn đề đc không ạ, chỉ mở một lần đầu tiên rồi thực hiện các công việc còn lại cho xong.
e gửi file nhờ mọi người giúp ạ

Thử code này xem sao?

Sub CallSub() 'Goi ca 3 cung luc
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Dim Wb As Workbook, i As Long, j As Long
    Dim dArr1, dArr2, dArr3, k, arr1, arr2, arr3
    
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
        dArr1 = Sheets("Bieu_08_Phi_LP").Range("C9:I57").Value
        dArr2 = Sheets("Bieu_26").Range("C9:v81").Value
        dArr3 = Sheets("Bieu_37").Range("C9:AU81").Value
    With Application.FileDialog(msoFileDialogFilePicker) 'chon file
        .AllowMultiSelect = True 'cho phep chon nhieu file
        If Not .Show = -1 Then MsgBox ("khong chon file nao de lam ak"), vbCritical, "Thong bao": Exit Sub
    For Each k In .SelectedItems
        Set Wb = Workbooks.Open(k)
        arr1 = Wb.Sheets("Bieu_08_Phi_LP").Range("C9:I57").Value
        arr2 = Wb.Sheets("Bieu_26").Range("C9:v81").Value
        arr3 = Wb.Sheets("Bieu_37").Range("C9:AU81").Value
        Wb.Close False
        
        'Bieu_08_Phi_LP
        For i = 1 To UBound(arr1, 1)
            For j = 1 To UBound(arr1, 2)
               If arr1(i, j) <> Empty And IsNumeric(arr1(i, j)) = True Then
                dArr1(i, j) = dArr1(i, j) + arr1(i, j)
               End If
            Next j
        Next i
        'Bieu_26
        For i = 1 To UBound(arr2, 1)
            For j = 1 To UBound(arr2, 2)
               If arr2(i, j) <> Empty And IsNumeric(arr2(i, j)) = True Then
                dArr2(i, j) = dArr3(i, j) + arr2(i, j)
               End If
            Next j
        Next i
        'Bieu_37
        For i = 1 To UBound(arr3, 1)
            For j = 1 To UBound(arr3, 2)
               If arr3(i, j) <> Empty And IsNumeric(arr3(i, j)) = True Then
                dArr3(i, j) = dArr3(i, j) + arr3(i, j)
               End If
            Next j
        Next i
    Next
    End With
    Sheets("Bieu_08_Phi_LP").Range("C9:I57").Value = dArr1
    Sheets("Bieu_26").Range("C9:v81").Value = dArr2
    Sheets("Bieu_37").Range("C9:AU81").Value = dArr3
    Application.ScreenUpdating = True
End Sub

 

[DarKLov3]

Thử code này xem sao?

Xin chân thành cám ơn bác @giaiphap nhiều nhé. Code chạy phà phà đúng ý tưởng luôn.


Tuy nhiên lại phát sinh vấn đề như này:
Tổng hợp xong rồi nhưng đây lại là file đuôi xlsm. Và còn có thêm cái nút bấm gọi code kia nữa,khi gửi báo cáo nhìn nó không được đẹp.
Vậy giờ e muốn tạo thêm 1 nút để xuất file sang 1 file excel mới với tên file là :" Tong hop + ngày/tháng/năm.xlsx" . Tên các sheet trong file mới này cũng giống y hệt trong file đuôi xlsm kia ạ.

E đã thử làm nhưng khi ấn xong thì nó copy cả mấy cái nút kia nữa nên vẫn chưa ổn lắm. Thôi thì tạo ribbon rồi add code vào thì cũng đỡ dc cái vụ nút bấm.
E làm code như này nói chung là thay việc ấn Save As trong Excel thôi nhưng về phần tên file thì chưa tự động điền ngày đc ạ. Và khi chạy thì nó tắt file đuôi xlsm luôn. Mọi người có cách nào xuất ra file mới mà file Tong hop du lieu.xlsm vẫn mở không ạ.

Sub xuatfile()
    ActiveWorkbook.Save
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\trung\OneDrive\Tong hop du lieu.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

End Sub

 

[nhnn1986]

Mình hay làm là:
1. Tạo 3 sheet theo đúng mẫu yêu cầu (A,B,C chẳng hạn => đổi tên khác theo yêu cầu)
2. Copy vũng dữ liệu từ các sheet do code chạy ra sang sheets A,B,C kia
3. Tại file mới và Copy các sheet A,B,C sang file mới tạo đó
Code của mình là tạo yêu cầu 3. còn 1. và 2. mình nghĩ bạn làm vô tư

Set newbook = Workbooks.Add
    ThisWorkbook.Sheets(array("A","B","C")).Copy before:=newbook.Sheets(newbook.Sheets.Count)
    On Error Resume Next
    newbook.Sheets(Array("Sheet1","Sheet2", "Sheet3")).Delete
    On Error GoTo 0
    newbook.SaveAs ThisWorkbook.Path & "\" & "Tong hop du lieu_" & Format(Date, "ddmmyyyy") & ".xlsx"
    newbook.Close SaveChanges:=False

 

[DarKLov3]

Báo cáo các bác là e đã làm đc ạ.

Sub XuatFile() ' xuat file moi
    
               On Error Resume Next
                Sheets(Array("Bieu_08_Phi_LP", "Bieu_26", "Bieu_37")).Select
                Sheets(Array("Bieu_08_Phi_LP", "Bieu_26", "Bieu_37")).COPY
                ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "Tong hop du lieu_" & Format(Now(), "ddmmyyyy hhmmss") & ".xlsx"
                Workbooks("Tong hop du lieu.xlsm").Activate
                Sheets("Bieu_37").Select
                
                
End Sub

 

[giaiphap]

Xin chân thành cám ơn bác @giaiphap nhiều nhé. Code chạy phà phà đúng ý tưởng luôn.


Tuy nhiên lại phát sinh vấn đề như này:
Tổng hợp xong rồi nhưng đây lại là file đuôi xlsm. Và còn có thêm cái nút bấm gọi code kia nữa,khi gửi báo cáo nhìn nó không được đẹp.
Vậy giờ e muốn tạo thêm 1 nút để xuất file sang 1 file excel mới với tên file là :" Tong hop + ngày/tháng/năm.xlsx" . Tên các sheet trong file mới này cũng giống y hệt trong file đuôi xlsm kia ạ.

E đã thử làm nhưng khi ấn xong thì nó copy cả mấy cái nút kia nữa nên vẫn chưa ổn lắm. Thôi thì tạo ribbon rồi add code vào thì cũng đỡ dc cái vụ nút bấm.
E làm code như này nói chung là thay việc ấn Save As trong Excel thôi nhưng về phần tên file thì chưa tự động điền ngày đc ạ. Và khi chạy thì nó tắt file đuôi xlsm luôn. Mọi người có cách nào xuất ra file mới mà file Tong hop du lieu.xlsm vẫn mở không ạ.

Sub xuatfile()
    ActiveWorkbook.Save
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\trung\OneDrive\Tong hop du lieu.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

End Sub

Bạn dùng thử code này xem sao, code chưa bẩy lỗi nhé, bạn tự bẩy lỗi cho riêng mình.

Sub xuatfile()
Dim Wb As Workbook
Dim btn As Shape
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
        Set Wb = Workbooks.Add
        ThisWorkbook.Sheets(Array("Bieu_08_Phi_LP", "Bieu_26", "Bieu_37")).Copy Before:=Wb.Sheets(1)
            For Each btn In Wb.Sheets("Bieu_08_Phi_LP").Shapes
                btn.Delete
            Next btn
        Wb.SaveAs Filename:=ThisWorkbook.Path & "\Tong hop " & Format(Now(), "DD_MM_YYYY") & ".xlsx", FileFormat:=51
        Wb.Close
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With
MsgBox "Da luu vao trong duong dan " & ThisWorkbook.Path & "\Tong hop " & Format(Now(), "DD_MM_YYYY") & ".xlsx"
End Sub