Untitled
unknown
plain_text
3 months ago
4.1 kB
4
Indexable
Sub ConsolidateData() Dim wsSummary As Worksheet Dim wb As Workbook Dim ws As Worksheet Dim lastRow As Long Dim lastCol As Long Dim folderPath As String Dim fileName As String Dim filePath As String Dim monthYear As String Dim sheetName As String Dim colOffset As Integer Dim i As Integer ' Đặt tên sheet tổng hợp Set wsSummary = ThisWorkbook.Sheets(1) wsSummary.Cells.Clear ' Đặt đường dẫn thư mục chứa các file Excel folderPath = "C:\Users\User\Desktop\test\" ' Thay đổi đường dẫn nếu cần ' Tiêu đề cột cho mỗi tháng Dim headers() As String headers = Split("Xa Tram,Ma,So KH,So HD,Tieu Thu,Cong Tien,T.thue GTGT,Tong Tien", ",") ' Điền tiêu đề cho tất cả các tháng từ 1 đến 12 For i = 1 To 12 colOffset = (i - 1) * (UBound(headers) + 2) + 1 ' Cách nhau 1 cột Dim j As Integer For j = LBound(headers) To UBound(headers) With wsSummary.Cells(1, colOffset + j) .Value = headers(j) & " Tháng " & i .Font.Bold = True .Font.Name = "Times New Roman" .Font.Size = 12 End With Next j ' Tô màu xám cho cột trống giữa các tháng wsSummary.Columns(colOffset + UBound(headers) + 1).Interior.Color = RGB(217, 217, 217) Next i ' Lấy danh sách các file trong thư mục fileName = Dir(folderPath & "*.xlsx") Do While fileName <> "" ' Mở file Excel filePath = folderPath & fileName Set wb = Workbooks.Open(filePath) ' Lấy thông tin tháng và năm từ tên file monthYear = Mid(fileName, InStr(fileName, "ky ") + 3, 6) sheetName = "tk" & monthYear ' Kiểm tra xem sheet có tồn tại không On Error Resume Next Set ws = wb.Sheets(sheetName) On Error GoTo 0 If Not ws Is Nothing Then ' Xác định vị trí cột cho tháng tương ứng i = CInt(Left(monthYear, 2)) ' Tháng colOffset = (i - 1) * (UBound(headers) + 2) + 1 ' Sao chép dữ liệu từ file lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then ws.Range(ws.Cells(2, 2), ws.Cells(lastRow, 9)).Copy wsSummary.Cells(2, colOffset).PasteSpecial Paste:=xlPasteValues End If End If ' Đóng file Excel wb.Close SaveChanges:=False ' Lấy file tiếp theo fileName = Dir Loop ' Định dạng font chữ toàn bộ bảng tổng hợp With wsSummary.Cells .Font.Name = "Times New Roman" .Font.Size = 12 End With ' Đặt viền cho toàn bộ bảng có dữ liệu lastRow = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row lastCol = wsSummary.Cells(1, wsSummary.Columns.Count).End(xlToLeft).Column If lastRow > 1 And lastCol > 1 Then With wsSummary.Range(wsSummary.Cells(1, 1), wsSummary.Cells(lastRow, lastCol)) .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideHorizontal).LineStyle = xlContinuous End With End If ' Định dạng số kiểu comma style và bỏ .00 For i = 2 To lastCol Step UBound(headers) + 2 With wsSummary.Range(wsSummary.Cells(2, i), wsSummary.Cells(lastRow, i + UBound(headers))) .NumberFormat = "#,##0" End With Next i MsgBox "Dữ liệu đã được tổng hợp và định dạng thành công!" End Sub
Editor is loading...
Leave a Comment