Tổng hợp dữ liệu nhiều file theo mẫu

[quick87]

Mình có công việc thường xuyên phải tổng hợp dữ liệu từ nhiều files xuất từ phần mềm vào file tổng hợp theo mẫu.
Vấn đề ở đây là mẫu phải tổng hợp khác với mẫu các files data xuất từ phần mềm ra, cụ thể:

- Mẫu file xuất từ phần mềm ra có dạng (data_xxx):



- Mẫu file cần tổng hợp (FIle tong hop):



- Cách lấy số liệu từ các files data xuất từ phần mềm sang file tổng hợp được lấy như sau:



Đính kèm là 02 file data xuất từ phần mềm và file mẫu cần tổng hợp. Mong được mọi người hỗ trợ viết giúp code để tổng hợp như mình có nêu phía trên.

Chân thành cảm ơn diễn đàn!

 

[befaint]

Phần mềm đó không tạo được bảng liệt kê luôn hả bạn?

Thấy đồ tiếng Anh xịn vậy cơ mà.

 

[quick87]

Phần mềm đó không tạo được bảng liệt kê luôn hả bạn?

Thấy đồ tiếng Anh xịn vậy cơ mà.

Vâng anh, việc tổng hợp này phần mềm họ không có hỗ trợ nên thực tế đang phải tổng hợp thủ công. Mong được anh và mọi người hỗ trợ giúp!

 

[befaint]

Quả thực, mình nhìn khúc song ngữ nản luôn.

 

[quick87]

Mình có mày mò và viết được code tạm như phía dưới, mong mọi người hướng dẫn và chỉnh giúp:

Option Explicit
Sub GetData_Main()
Dim FOb As Object, Fso As Object, Item, cn As Object, rs As Object, fOld As String, fNew As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
    fOld = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    fNew = ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
Else
    fOld = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    fNew = ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
End If
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
Range("A2").CurrentRegion.Offset(1).ClearContents
On Error Resume Next
For Each Item In .SelectedItems
    If Left(Item, 1) <> "~" Then
        cn.Open (fOld & Item & fNew)
            'Set rs = cn.Execute("select * from [Journal Report$A7:C] where F1 Is Not Null")
            Set rs = cn.Execute("select * from [Journal Report$A7:C] where F1 <> ''")
            If Not rs.EOF Then Range("J65000").End(3)(2).CopyFromRecordset rs
            rs.Close
            cn.Close
    End If
Next Item
End With
Set cn = Nothing
Set rs = Nothing
'MsgBox "Done!"
Call ChuyenDoi
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub ChuyenDoi()
Dim lastRow
    Range("A2").Formula = "=--IF(LEFT(J2,2)<>""ID"",A1,L2)"
    Range("B2").Formula = "=MID(C2,3,7)"
    Range("C2").Formula = "=IF(LEFT(J2,2)=""ID"",J2,C1)"
    Range("D2").Formula = "=SUBSTITUTE(MID(J2,FIND(""("",J2),7),""("","""")"
    Range("E2").Formula = "=LEFT(J2,LEN(J2)-LEN(D2)-2)"
    Range("F2").Formula = "=K2"
    Range("G2").Formula = "=L2"
    Columns("A:A").NumberFormat = "dd/MM/yyyy"
    Columns("F:G").NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
   
    lastRow = Sheets("Sheet1").Range("J" & Rows.Count).End(xlUp).Row
    Range("A2:G" & lastRow).FillDown
    Range("A2:G" & lastRow).Value = Range("A2:G" & lastRow).Value
    Columns("I:O").EntireColumn.Delete
       
    Application.ScreenUpdating = False
    Range("A1:G" & lastRow).AutoFilter Field:=5, Criteria1:="=*ID*", Operator:=xlOr, Criteria2:="=#VALUE!"
    Range([a2], [a2].End(xlDown)).EntireRow.Delete
    ActiveSheet.ShowAllData
    Application.ScreenUpdating = True
   
End Sub

Chân thành cảm ơn!

 

[HUONGHCKT]

Mình có công việc thường xuyên phải tổng hợp dữ liệu từ nhiều files xuất từ phần mềm vào file tổng hợp theo mẫu.
Vấn đề ở đây là mẫu phải tổng hợp khác với mẫu các files data xuất từ phần mềm ra, cụ thể:

- Mẫu file xuất từ phần mềm ra có dạng (data_xxx):

View attachment 270137

- Mẫu file cần tổng hợp (FIle tong hop):

View attachment 270138

- Cách lấy số liệu từ các files data xuất từ phần mềm sang file tổng hợp được lấy như sau:

View attachment 270140

Đính kèm là 02 file data xuất từ phần mềm và file mẫu cần tổng hợp. Mong được mọi người hỗ trợ viết giúp code để tổng hợp như mình có nêu phía trên.

Chân thành cảm ơn diễn đàn!

Góp thêm một cách nữa cho bạn tham khảo.
mở file Tonghop lên vào Sheet1 click nút Tong Hop Ket Quả và nhận kết quả.
Kết quả trả về đang để ở A25...
Bạn kiểm tra lại đường dẫn và thay đổi cho đúng đích bạn muốn lấy

Option Explicit
Sub TongHop()
Dim Lr&, i&, t&, k&
Dim Arr(), KQ(), eKQ(), S
Dim fso As Object
Dim Ws As Worksheet, WbMoi As Workbook
Dim file As Variant

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
Set fso = CreateObject("Scripting.FileSystemObject")
    ReDim eKQ(1 To 1000, 1 To 3)
    ReDim KQ(1 To 10000, 1 To 8)

For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\").Files
    If file.Name Like "data_*.xls" Then
        Set WbMoi = Workbooks.Open(file)
        For Each Ws In WbMoi.Sheets
            If Ws.Name = "Journal Report" Then

                Lr = Ws.Cells(Rows.Count, 1).End(xlUp).Row
                Arr = Ws.Range("A7:C" & Lr).Value
                For i = 1 To UBound(Arr)
                    If Arr(i, 1) <> Empty Then
                        If Mid(Arr(i, 1), 1, 2) = "ID" Then
                            k = k + 1
                            eKQ(k, 1) = Arr(i, 3)
                            eKQ(k, 2) = Mid(Arr(i, 1), 4, 9)
                            eKQ(k, 3) = Arr(i, 1)
                        End If
                        
                        If Arr(i, 1) <> "Account" And Mid(Arr(i, 1), 1, 2) <> "ID" Then
                            t = t + 1
                            KQ(t, 1) = eKQ(k, 1)
                            KQ(t, 2) = eKQ(k, 2)
                            KQ(t, 3) = eKQ(k, 3)
                            KQ(t, 4) = Arr(i, 1)
                            KQ(t, 5) = Arr(i, 1)
                            S = Split(Arr(i, 1))
                            KQ(t, 5) = S(UBound(S)) * -1
                            KQ(t, 6) = Arr(i, 2)
                            KQ(t, 7) = Arr(i, 3)
                            KQ(t, 8) = file.Name
                        End If
                    End If
                Next i
            End If
        Next Ws
WbMoi.Close
    End If
Next file

Sheet1.Range("A25").Resize(10000, 8).ClearContents
Sheet1.Range("A25").Resize(t, 8) = KQ

Set fso = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Tông hơp dư liêu tư các file data_....xls đa thành công", vbInformation, "THÔNG BÁO"
End Sub

Xem file đính kèm

 

[Hoàng Tuấn 868]

Quả thực, mình nhìn khúc song ngữ nản luôn.

Anh thế là vẫn vất vả, như em nhìn thấy đoạn đấy là thảnh thơi luôn vì không nghĩ đến nó nữa.

 

[VetMini]

Quả thực, mình nhìn khúc song ngữ nản luôn.

Anh thế là vẫn vất vả, như em nhìn thấy đoạn đấy là thảnh thơi luôn vì không nghĩ đến nó nữa.

Phần mềm tiếng Anh, dữ liệu tiếng Việt chứ song ngữ đâu.
Nhưng tôi vẫn không hiểu đem đổ cái nhật ký từ phần mềm kế toán ra Excel làm cái chi chi? Kiểm toán à?

 

[HieuCD]

Mình có mày mò và viết được code tạm như phía dưới, mong mọi người hướng dẫn và chỉnh giúp:

Option Explicit
Sub GetData_Main()
Dim FOb As Object, Fso As Object, Item, cn As Object, rs As Object, fOld As String, fNew As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
    fOld = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    fNew = ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
Else
    fOld = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    fNew = ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
End If
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
Range("A2").CurrentRegion.Offset(1).ClearContents
On Error Resume Next
For Each Item In .SelectedItems
    If Left(Item, 1) <> "~" Then
        cn.Open (fOld & Item & fNew)
            'Set rs = cn.Execute("select * from [Journal Report$A7:C] where F1 Is Not Null")
            Set rs = cn.Execute("select * from [Journal Report$A7:C] where F1 <> ''")
            If Not rs.EOF Then Range("J65000").End(3)(2).CopyFromRecordset rs
            rs.Close
            cn.Close
    End If
Next Item
End With
Set cn = Nothing
Set rs = Nothing
'MsgBox "Done!"
Call ChuyenDoi
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub ChuyenDoi()
Dim lastRow
    Range("A2").Formula = "=--IF(LEFT(J2,2)<>""ID"",A1,L2)"
    Range("B2").Formula = "=MID(C2,3,7)"
    Range("C2").Formula = "=IF(LEFT(J2,2)=""ID"",J2,C1)"
    Range("D2").Formula = "=SUBSTITUTE(MID(J2,FIND(""("",J2),7),""("","""")"
    Range("E2").Formula = "=LEFT(J2,LEN(J2)-LEN(D2)-2)"
    Range("F2").Formula = "=K2"
    Range("G2").Formula = "=L2"
    Columns("A:A").NumberFormat = "dd/MM/yyyy"
    Columns("F:G").NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
  
    lastRow = Sheets("Sheet1").Range("J" & Rows.Count).End(xlUp).Row
    Range("A2:G" & lastRow).FillDown
    Range("A2:G" & lastRow).Value = Range("A2:G" & lastRow).Value
    Columns("I:O").EntireColumn.Delete
      
    Application.ScreenUpdating = False
    Range("A1:G" & lastRow).AutoFilter Field:=5, Criteria1:="=*ID*", Operator:=xlOr, Criteria2:="=#VALUE!"
    Range([a2], [a2].End(xlDown)).EntireRow.Delete
    ActiveSheet.ShowAllData
    Application.ScreenUpdating = True
  
End Sub

Chân thành cảm ơn!

Chỉnh lại

Option Explicit
Sub GetData_ADO()
  Dim FOb As Object, Item, cn As Object, rs As Object
  Dim arr, res(), S, i&, k&, fRow&, jDes$, jNum$, jDate As Date
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set cn = CreateObject("ADODB.Connection")
  With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
      MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
      Exit Sub
    End If
    Range("A2").CurrentRegion.Offset(1).ClearContents
    On Error Resume Next
    For Each Item In .SelectedItems
      If Left(Item, 1) <> "~" Then
        cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Item & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
        Set rs = cn.Execute("select * from [Journal Report$A7:C500] where F1 is not Null or F2 is not Null")
        If Not rs.EOF Then
          arr = rs.GetRows
          k = 0
          S = Split(Item, "\")
          Item = Split(S(UBound(S)), ".")(0)
          ReDim res(1 To UBound(arr, 2), 1 To 8)
          For i = 0 To UBound(arr, 2)
            If arr(0, i) <> Empty Then
              If Left(arr(0, i), 2) = "ID" Then
                jDes = arr(0, i)
                jNum = Split(jDes, " ")(1)
                jDate = arr(2, i)
              ElseIf IsNumeric(arr(1, i)) Or IsNumeric(arr(2, i)) Then
                k = k + 1
                res(k, 1) = jDate: res(k, 2) = jNum: res(k, 3) = jDes: res(k, 8) = Item
                S = Split(arr(0, i), " ")
                S = S(UBound(S))
                res(k, 4) = Mid(S, 2, Len(S) - 2)
                res(k, 5) = Mid(arr(0, i), 1, Len(arr(0, i)) - Len(S) - 1)
                If IsNumeric(arr(1, i)) Then
                  res(k, 6) = Val(Replace(arr(1, i), ",", ""))
                Else
                  res(k, 7) = Val(Replace(arr(2, i), ",", ""))
                End If
              End If
            End If
          Next i
          fRow = Range("A" & Rows.Count).End(xlUp).Row + 1
          Range("B" & fRow).Resize(k).NumberFormat = "@"
          Range("D" & fRow).Resize(k).NumberFormat = "@"
          Range("A" & fRow).Resize(k, 8) = res
        End If
        rs.Close:            cn.Close
      End If
    Next Item
  End With
  Set cn = Nothing:   Set rs = Nothing
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

 

[quick87]

Trân trọng cảm ơn mọi người đã chung tay giúp đỡ ạ!