Giúp tổng hợp dữ liệu từ nhiều file excel có chọn lọc (1 người xem)

[hnilinh]

Mình là thành viên mới của diễn đàn, mong mọi người giúp đỡ.
Hằng tuần mình đều làm báo cáo theo mẫu giống nhau, trong đó tên file báo cáo cũng là thời gian.

Mình cần tạo một file tổng hợp. Mỗi tuần khi thêm file báo cáo mới vào thư mục và chạy marco thì file tổng hợp sẽ tạo ra một cột mới với tên cột là tên của file báo cáo (thời gian) và nội dung cột được lấy từ nội dung cột của từng file báo cáo.

Mình có đính kèm các file báo cáo của 3 tuần và file tổng hợp mong muốn đạt được.
Cảm ơn mọi người trước.

 

[HieuCD]

các file nằm trong cùng 1 folder
các file nào tổng hợp rồi thì không tổng hợp lần 2

Sub TongHop()
  Dim WB As Workbook, FSO As Object, FileItem As Object
  Dim Dic As Object, Darr(), Arr(), Sarr(1 To 5, 1 To 100), LastC As Long, Tmp, DateMin As Long
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set Dic = CreateObject("scripting.dictionary")
  Dic.Item(ThisWorkbook.Name) = ""
  LastC = Range("C4").End(xlToRight).Column
  If LastC > 4 Then
    For j = 5 To LastC
      Tmp = Cells(4, j).Value
      Dic.Item(Tmp) = ""
    Next j
  End If
  Set FSO = CreateObject("Scripting.FileSystemObject")
  For Each FileItem In FSO.GetFolder(ThisWorkbook.Path).Files
    Tmp = FileItem.Name
    If UCase(Right(FileItem.Name, 4)) = "XLSX" Then
      Tmp = Left(FileItem.Name, Len(FileItem.Name) - 5)
      If Not Dic.exists(Tmp) Then
        Set WB = Workbooks.Open(FileItem.Path)
        Darr = WB.Sheets("Sheet1").Range("E5:E8").Value
        WB.Close False
        k = k + 1: Sarr(1, k) = Tmp
        For i = 1 To 4
          Sarr(i + 1, k) = Darr(i, 1)
        Next i
      End If
    End If
  Next FileItem
  Set FileItem = Nothing:  Set FSO = Nothing:  Set WB = Nothing:  Set Dic = Nothing
  If k Then
  ReDim Arr(1 To 5, 1 To k)
  ReDim Darr(42736 To 50000)
  DateMin = 50000
  For j = 1 To k
    Tmp = DateSerial(CLng(Mid(Sarr(1, j), 7, 4)), CLng(Mid(Sarr(1, j), 4, 2)), CLng(Mid(Sarr(1, j), 1, 2)))
    Tmp = CLng(Tmp)
    a = CLng(Cells(10 + j, 5))
    Darr(Tmp) = j
    If DateMin > Tmp Then DateMin = Tmp
  Next j
  For j = DateMin To 50000
    If Darr(j) > 0 Then
      jk = jk + 1
      For i = 1 To 5
        Arr(i, jk) = Sarr(i, Darr(j))
      Next i
      If ik = k Then Exit For
    End If
  Next j
  Cells(4, LastC + 1).Resize(5, k) = Arr
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[hnilinh]

Cảm ơn bạn rất nhiều!
Cho mình hỏi là khi mình đổi tên các file báo cáo thành định dạng text thì khi chạy marco báo là type mismatch, vậy phải đổi định dạng này ở đâu để có thể hiển thị dạng text.

 

[HieuCD]

Cảm ơn bạn rất nhiều!
Cho mình hỏi là khi mình đổi tên các file báo cáo thành định dạng text thì khi chạy marco báo là type mismatch, vậy phải đổi định dạng này ở đâu để có thể hiển thị dạng text.

"đổi tên các file báo cáo thành định dạng text" bạn thực hiện như thế nào, gởi file lên xem mới biết được

 

[hnilinh]

Ý mình là tên các file ở dạng text như ở dưới chứ ko phải số ấy.

 

[befaint]

Ý mình là tên các file ở dạng text như ở dưới chứ ko phải số ấy.

Nhất định là xài chữ tiếng Việt có dấu cơ?
"Người ta" khuyến cáo sử dụng chữ không dấu thôi.
File ở bài #1 đặt tên nhưng vậy là đủ hiểu rồi...

 

[hnilinh]

Nhất định là xài chữ tiếng Việt có dấu cơ?
"Người ta" khuyến cáo sử dụng chữ không dấu thôi.
File ở bài #1 đặt tên nhưng vậy là đủ hiểu rồi...

Mình đã thử tên bằng tiếng Việt không dấu mà vẫn bị lỗi Type mismatch đó bạn, marco chỉ nhận dạng chữ số thôi. Nên mình mới hỏi định dạng đó ở đâu để sửa lại, lần sau không phải hỏi nữa.

 

[befaint]

Mình đã thử tên bằng tiếng Việt không dấu mà vẫn bị lỗi Type mismatch đó bạn, marco chỉ nhận dạng chữ số thôi. Nên mình mới hỏi định dạng đó ở đâu để sửa lại, lần sau không phải hỏi nữa.

Vậy bạn cần chụp màn hình lỗi rồi gửi lên, xem lỗi ở dòng nào thì anh HieuCD mới biết để chỉnh lại cho bạn!!!

 

[hnilinh]

If k Then
ReDim Arr(1 To 5, 1 To k)
ReDim Darr(42736 To 50000)
DateMin = 50000
For j = 1 To k
Tmp = DateSerial(CLng(Mid(Sarr(1, j), 7, 4)), CLng(Mid(Sarr(1, j), 4, 2)), CLng(Mid(Sarr(1, j), 1, 2)))
Tmp = CLng(Tmp)
a = CLng(Cells(10 + j, 5))
Darr(Tmp) = j
If DateMin > Tmp Then DateMin = Tmp
Next j
For j = DateMin To 50000
If Darr(j) > 0 Then
jk = jk + 1
For i = 1 To 5
Arr(i, jk) = Sarr(i, Darr(j))
Next i
If ik = k Then Exit For
End If

Dòng lỗi được tô đậm! Nhờ anh Hiếu CD giải thích giùm!

 

[HieuCD]

If k Then
ReDim Arr(1 To 5, 1 To k)
ReDim Darr(42736 To 50000)
DateMin = 50000
For j = 1 To k
Tmp = DateSerial(CLng(Mid(Sarr(1, j), 7, 4)), CLng(Mid(Sarr(1, j), 4, 2)), CLng(Mid(Sarr(1, j), 1, 2)))
Tmp = CLng(Tmp)
a = CLng(Cells(10 + j, 5))
Darr(Tmp) = j
If DateMin > Tmp Then DateMin = Tmp
Next j
For j = DateMin To 50000
If Darr(j) > 0 Then
jk = jk + 1
For i = 1 To 5
Arr(i, jk) = Sarr(i, Darr(j))
Next i
If ik = k Then Exit For
End If

Dòng lỗi được tô đậm! Nhờ anh Hiếu CD giải thích giùm!

hàm mid lấy ngày tháng năm, vị trí thay đổi nên không lấy đúng các con số
nếu tên file thống nhất thì chỉ cần sửa một dòng lệnh đó là được, viết thêm vòng lập tìm ngày tháng cho chắc, bạn chỉnh lại đoạn code

  For j = 1 To k
    Tmp = Sarr(1, j)
    For i = 1 To Len(Tmp)
      If IsNumeric(Mid(Tmp, i, 1)) Then Exit For
    Next i
    Tmp = DateSerial(CLng(Mid(Sarr(1, j), i + 6, 4)), CLng(Mid(Sarr(1, j), i + 3, 2)), CLng(Mid(Sarr(1, j), i, 2)))
    Tmp = CLng(Tmp)
    Darr(Tmp) = j
    If DateMin > Tmp Then DateMin = Tmp
  Next j

 

[hnilinh]

hàm mid lấy ngày tháng năm, vị trí thay đổi nên không lấy đúng các con số
nếu tên file thống nhất thì chỉ cần sửa một dòng lệnh đó là được, viết thêm vòng lập tìm ngày tháng cho chắc, bạn chỉnh lại đoạn code

  For j = 1 To k
    Tmp = Sarr(1, j)
    For i = 1 To Len(Tmp)
      If IsNumeric(Mid(Tmp, i, 1)) Then Exit For
    Next i
    Tmp = DateSerial(CLng(Mid(Sarr(1, j), i + 6, 4)), CLng(Mid(Sarr(1, j), i + 3, 2)), CLng(Mid(Sarr(1, j), i, 2)))
    Tmp = CLng(Tmp)
    Darr(Tmp) = j
    If DateMin > Tmp Then DateMin = Tmp
  Next j

Đoạn code này tuy quét được ngày tháng năm trong tên file nhưng lại xuất hiện một vấn đề khác là gây ra lặp.
Mỗi lần chạy lại macro thì các file tổng hợp rồi lại bị tổng hợp lần 2. Nhờ bạn xem giúp

 

[HieuCD]

Đoạn code này tuy quét được ngày tháng năm trong tên file nhưng lại xuất hiện một vấn đề khác là gây ra lặp.
Mỗi lần chạy lại macro thì các file tổng hợp rồi lại bị tổng hợp lần 2. Nhờ bạn xem giúp

file đã tổng hợp bạn không được thay đổi tiêu đề của bảng và tên file, lúc đó chắc chắn không lập. còn bạn sửa lung tung thì chỉ có bạn mới biết file nào đã tổng hợp file nào chưa, và chịu khó làm bằng tay vậy

 

[hnilinh]

Mình đã sửa lại và hoạt động theo mong muốn. Cảm ơn bạn nhiều!