Hợp nhất nhiều File vào 1 file và tự động tổng hợp
Hôm nay nay tôi đưa ra ý tưởng làm thế nào để hợp nhất dữ liệu nhiều File vào 1 file trong Excel.
Giả sử bạn theo dõi công việc trong nhiều năm, mỗi năm chứa dữ liệu trong 1 File hoặc bạn theo dõi công việc của 1 năm với mỗi File là 1 tháng, vậy làm sao để gộp dữ liệu của nhiều File vào 1 File tổng.
Ý tưởng của tôi là viết 1 Macro và gán macro này cho 1 nút lệnh, khi nhấn vào nút này nó sẽ hiện ra hộp thoại Open Files, chọn ổ dĩa và chọn mở thư mục, tiếp theo chọn tất cả các File cần hợp nhất và nhấn nút Open, macro sẽ chạy và gán tất các các sheet chứa trong các File vừa chọn và File tổng.
Tiếp theo là nhấn vào nút lệnh hợp nhất các sheet, macro sẽ chạy và gộp dữ liệu của các sheet vừa gán vào File tổng vào sheet tổng, tiếp theo nhấn vào nút lệnh tổng hợp macro sẽ chạy tự lấy dữ liệu từ sheet tổng và tạo ra Pivottable với kết quả mình cần tổng hợp báo cáo.
Đây là 1 vấn đề mới mà trên diễn đàn giải pháp Excel chưa có ai đưa ra ý tưởng này vì nó thuộc đề tài khó, tôi đưa ra ý tưởng này để cùng để cùng nhau tháo gỡ mọi khó khăn vướng mắc trong việc tổng hợp và báo cáo hàng quý, hàng năm hoặc tổng hợp kết quả cho 1 giai đoạn (5 năm), nếu thực hiện tốt ý tưởng này tôi dám cam đoan với các bạn chỉ trong vòng 5 đến 10 phút bạn sẽ có ngay kết quả mình cần.
Nếu các bạn nào quan tâm đến vấn đề này thì hãy tham gia và cùng nhau thảo luận, đóng góp hoặc trong công việc gặp vấn đề như tôi vừa nêu do sếp hay lãnh đạo bắt phải theo dõi từng File 1 cách rời rạc nên việc theo dõi, tổng hợp báo cáo quá khó khăn, bây giờ các bạn cần 1 ứng dụng để tháo gỡ mọi khó khăn như vấn đề nêu trên, thì các bạn cần nêu các vấn đề khó khăn và nêu yêu cầu cần giúp, xong tải File lên tôi sẽ nghiên cứu và sẽ giúp đỡ theo yêu cầu của các bạn.
Lưu ý: để có kết quả đúng thì cần các tiêu chí sau đây:
- Tiêu đề của các sheet chứa trong File phải hoàn toàn giống nhau (tiêu đề không được Merge and center (nhập ô).
- Tên từng sheet phải cụ thể rõ ràng để dễ dàng kiểm tra lại kết quả (nếu tên sheet trùng thì nó tự động đặt 1 và 2).
- Để được kết quả đúng thì cần đề ra nội dung cần tổng hợp báo cáo (vì Macro dùng chạy Pivottable được viết dựa trên tiêu đề cột).
tạo 2 module:
#1: Module CommonFunctions
(code)
===========================
Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
' If Dir(wbPath & "\" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Sub CopyValuesFromAClosedWorkbook(fPath As String, _
fName As String, srcSheet As String, srcRange As String, desSheet As String, desRange As String)
With Worksheets(desSheet).Range(desRange)
.FormulaArray = "='" & fPath & "\[" & fName & "]" _
& srcSheet & "'!" & srcRange
.Value = .Value
End With
End Sub
Public Function ColumnNumberToLetter(ByVal lngNumber As Long) As String
ColumnNumberToLetter = Split(ThisWorkbook.Worksheets(1).Columns(lngNumber).Address, ":")(0)
End Function
Public Function ColumnLetterToNumber(ByVal strLetter As String) As Long
ColumnLetterToNumber = ThisWorkbook.Worksheets(1).Columns(strLetter).Column
End Function
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
sItem = ""
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Chon thu muc chua file du lieu cac Phong"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub ProcessRange(sPath As String, sFile As String, sSheet As String, _
minCol As String, minRow As String, _
maxCol As String, maxRow As String, tempCol As String)
Dim col As Integer
Dim row As Integer
Dim sRange As String
Dim tRange As String
Dim tempRange As String
sRange = minCol & minRow & ":" & maxCol & maxRow
tRange = tempCol & minRow & ":" & _
ColumnNumberToLetter(ColumnLetterToNumber(maxCol) - ColumnLetterToNumber(minCol) + ColumnLetterToNumber(tempCol)) & _
maxRow
Call CopyValuesFromAClosedWorkbook(sPath, sFile, sSheet, sRange, sSheet, tRange)
For col = ColumnLetterToNumber(minCol) To ColumnLetterToNumber(maxCol)
For row = minRow To maxRow
sRange = ColumnNumberToLetter(col) & row
tempRange = ColumnNumberToLetter(ColumnLetterToNumber(tempCol) + col - ColumnLetterToNumber(minCol)) & row
iTemp = ThisWorkbook.Worksheets(sSheet).Range(sRange).Value
iTemp = iTemp + ThisWorkbook.Worksheets(sSheet).Range(tempRange).Value
ThisWorkbook.Worksheets(sSheet).Range(sRange).Value = iTemp
Next
Next
ThisWorkbook.Worksheets(sSheet).Range(tRange).ClearContents
End Sub
===============================================================
#2: Main
(code)
===========================
Sub RealCapNhat(sPath As String, sheetName As String, colMax As String, cellMonth As String, cellYear As String, _
Optional cnKQ As Boolean)
Dim iCount As Integer
Dim sFile As String
Dim sRange As String
Dim i As Integer
Dim bOthersUpdated As Boolean
Password = "0986886338"
ThisWorkbook.Worksheets(sheetName).Unprotect Password
iCount = 0
If sPath <> "" Then
'Xoa het cac dong cu
'Clear 10 dong dau
ThisWorkbook.Worksheets(sheetName).Range("A8:" & colMax & "17").ClearContents
'Xoa cac dong tiep theo
Do While ThisWorkbook.Worksheets(sheetName).Range("A18").Value <> "END"
ThisWorkbook.Worksheets(sheetName).Rows(18).EntireRow.Delete
Loop
ThisWorkbook.Worksheets(sheetName).Range("G2").ClearContents
sMask = sPath & "\*.xls"
sFile = Dir(sMask)
bOthersUpdated = False
Do While Len(sFile) > 0
'==============================================================================
'Xu ly doi voi tung file du lieu Xa
iTemp = ThisWorkbook.Worksheets(sheetName).Range("G2").Value
iTemp = iTemp + GetInfoFromClosedFile(sPath, sFile, sheetName, "B18")
ThisWorkbook.Worksheets(sheetName).Range("G2").Value = iTemp
If bOthersUpdated <> True Then
'Tinh, Huyen
ThisWorkbook.Worksheets(sheetName).Range("C1").Value = GetInfoFromClosedFile(sPath, sFile, sheetName, "C1")
ThisWorkbook.Worksheets(sheetName).Range("C2").Value = GetInfoFromClosedFile(sPath, sFile, sheetName, "C2")
'Thoi diem
ThisWorkbook.Worksheets(sheetName).Range(cellYear).Value = GetInfoFromClosedFile(sPath, sFile, sheetName, cellYear)
ThisWorkbook.Worksheets(sheetName).Range(cellMonth).Value = GetInfoFromClosedFile(sPath, sFile, sheetName, cellMonth)
bOthersUpdated = True
End If
'Insert them dong neu can thiet
If iCount >= 10 Then
ThisWorkbook.Worksheets(sheetName).Rows(iCount + 7).EntireRow.Insert
ThisWorkbook.Worksheets(sheetName).Range("A" & (iCount + 7) & ":" & colMax & (iCount + 7)).Value = _
ThisWorkbook.Worksheets(sheetName).Range("A" & (iCount + 8) & ":" & colMax & (iCount + 8)).Value
End If
'STT
sRange = "A" & (8 + iCount)
ThisWorkbook.Worksheets(sheetName).Range(sRange).Value = iCount + 1
'Ten xa
sRange = "B" & (8 + iCount)
ThisWorkbook.Worksheets(sheetName).Range(sRange).Value = GetInfoFromClosedFile(sPath, sFile, sheetName, "C3")
'Du lieu
sRange = "C" & (8 + iCount) & ":" & colMax & (8 + iCount)
Call CopyValuesFromAClosedWorkbook(sPath, sFile, sheetName, "C18:" & colMax & "18", sheetName, sRange)
'Ket qua
If cnKQ Then
sRange = "AC" & (8 + iCount)
ThisWorkbook.Worksheets(sheetName).Range(sRange).Value = GetInfoFromClosedFile(sPath, sFile, sheetName, "C23")
End If
'==============================================================================
iCount = iCount + 1
sFile = Dir()
Loop
End If
If cnKQ Then
If iCount > 10 Then
iCountR = iCount
Else
iCountR = 10
End If
sRange = "D" & (17 + iCountR)
ThisWorkbook.Worksheets(sheetName).Range(sRange).Value = _
ThisWorkbook.Worksheets("CSVC").Range("G2").Value
End If
ThisWorkbook.Worksheets(sheetName).Protect Password, True, True, True
End Sub
Sub CapNhatDoTuoi(sPath As String)
Dim iCount As Integer
Dim iTemp As Integer
Dim sFile As String
Dim i As Integer
Dim sheetName As String
sheetName = "DoTuoi"
Password = "0986886338"
ThisWorkbook.Worksheets(sheetName).Unprotect Password
iCount = 0
If sPath <> "" Then
'Clear data
ThisWorkbook.Worksheets(sheetName).Range("F6:Q59").ClearContents
sMask = sPath & "\*.xls"
sFile = Dir(sMask)
Do While Len(sFile) > 0
'Xu ly doi voi tung file du lieu Phong
Call ProcessRange(sPath, sFile, sheetName, "F", "6", "Q", "59", "R")
iCount = iCount + 1
sFile = Dir()
Loop
End If
ThisWorkbook.Worksheets(sheetName).Protect Password, True, True, True
End Sub
Sub CapNhatKhac(sPath As String)
Dim iCountT(1 To 4) As Integer
Dim i As Integer
Dim sFile As String
Dim sRange As String
Dim iCount As Integer
Dim sheetName As String
sheetName = "GV"
For i = 1 To 4
iCountT(i) = 0
Next i
Password = "0986886338"
ThisWorkbook.Worksheets(sheetName).Unprotect Password
iCount = 0
If sPath <> "" Then
sMask = sPath & "\*.xls"
sFile = Dir(sMask)
Do While Len(sFile) > 0
'Xu ly doi voi tung file du lieu Phong
sTemp = GetInfoFromClosedFile(sPath, sFile, sheetName, "C24")
Select Case sTemp
Case "PC"
iCountT(1) = iCountT(1) + 1
Case "M1"
iCountT(2) = iCountT(2) + 1
Case "M2"
iCountT(3) = iCountT(3) + 1
Case "KO"
iCountT(4) = iCountT(4) + 1
End Select
sFile = Dir()
iCount = iCount + 1
Loop
End If
'Clear data
ThisWorkbook.Worksheets(sheetName).Range("D" & (iCount + 13) & "
" & (iCount + 16)).ClearContents
'Set data
ThisWorkbook.Worksheets(sheetName).Range("D" & (iCount + 13)).Value = iCountT(1)
ThisWorkbook.Worksheets(sheetName).Range("D" & (iCount + 14)).Value = iCountT(2)
ThisWorkbook.Worksheets(sheetName).Range("D" & (iCount + 15)).Value = iCountT(3)
ThisWorkbook.Worksheets(sheetName).Range("D" & (iCount + 16)).Value = iCountT(4)
ThisWorkbook.Worksheets(sheetName).Protect Password, True, True, True
End Sub
Sub CapNhat()
Dim sPath As String
sPath = GetFolder(ThisWorkbook.Path)
If sPath <> "" Then
Call RealCapNhat(sPath, "CSVC", "AI", "T2", "W2")
Call RealCapNhat(sPath, "GV", "AC", "R2", "T2", True)
Call CapNhatDoTuoi(sPath)
MsgBox ("Da cap nhat xong")
End If
End Sub