Lập báo cáo so sánh 2 files theo điều kiện

Liên hệ QC
bigbabol89

bigbabol89

Thành viên thường trực
Tham gia
15/10/12
Bài viết
224
Được thích
34
Em chào các anh chị,
Nhờ các anh chị giúp em : tạo báo cáo theo phương pháp so sánh 2 file theo 2 điều kiện.
Em có mô tả chi tiết trong file "Tong hop" ạ.
Em cám ơn các anh chị !
 

File đính kèm

  • File 1.xlsx
    9.9 KB · Đọc: 21
  • File 2.xlsx
    9.1 KB · Đọc: 19
  • Tong hop.xlsx
    11.2 KB · Đọc: 24
Có ai ghé qua giúp em với, nếu đề bài em diễn tả khó hiểu ở đâu em sẽ giải thích ạ :(
 
Bài so sánh liệt kê này chắc chỉ dùng VBA thôi bạn ạ
 
Lần chỉnh sửa cuối:
mà cũng khá rắc rối đấy vì hai file vị trí cột không giống nhau không nói còn tên tiêu để cột để mà gán cho 150 cột cũng là một vấn đế,mà còn so sánh hết cả dòng thế cứ mỗi dòng phải chạy lượt so sánh xong không thỏa mãn lại làm vòng nữa gán kết quả.
 
bigbabol89 đã viết:
Nhờ các anh chị giúp em : tạo báo cáo theo phương pháp so sánh 2 file theo 2 điều kiện.
Nhấp chuột vào đây để mở rộng...

Bài này nếu dùng câu lệnh SQL thì nó như thế này: (code giả định). Tôi nghĩ dùng Power Query sẽ nhan hơn, khỏi cần dùng ADO.
(Tôi không biết PQ)

Mã: 
SELECT File1.[Ma so], File1.[So tien], File2.[So tien], File1.[Ten ngan hang], File2.[Ten ngan hang]
FROM File1 INNER JOIN File2 ON File1.[Ma so] = File2.[Ma so]
WHERE ([File2].[Ten ngan hang]<>[File1].[Ten ngan hang]) OR ([File2].[So tien])<>[File1].[So tien])
 
bigbabol89 đã viết:
Em chào các anh chị,
Nhờ các anh chị giúp em : tạo báo cáo theo phương pháp so sánh 2 file theo 2 điều kiện.
Em có mô tả chi tiết trong file "Tong hop" ạ.
Em cám ơn các anh chị !
Nhấp chuột vào đây để mở rộng...
Điều kiện so sánh nhập tay chính xác vào sheet DieuKien
Mã: 
Sub Main()
  Dim FSo As Object, Dic As Object
  Dim aDK(), Arr1, Arr2, aCol(), Res()
  Dim File1$, File2$, maSo$
  Dim eRow&, srDK&, sRow&, sCol&, j&, i&, ik&, jC&
 
  Set FSo = CreateObject("Scripting.FileSystemObject")
  With Sheets("DieuKien")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co dieu kien so sanh"): Exit Sub
    File1 = .Range("A2").Value
    If Right(File1, 1) <> "\" Then File1 = File1 & "\" & .Range("A3").Value Else File1 = File1 & .Range("A3").Value
    File2 = .Range("B2").Value
    If Right(File2, 1) <> "\" Then File2 = File2 & "\" & .Range("B3").Value Else File2 = File2 & .Range("B3").Value
    If FSo.FileExists(File1) = False Or FSo.FileExists(File2) = False Then MsgBox ("Ten Thu muc và File khong dung"): Exit Sub
    aDK = .Range("A5:C" & eRow).Value
    srDK = UBound(aDK) 'So dong bang dieu kien
    sCol = Application.Max(.Range("A5:A" & eRow))
    Arr1 = Get_Arr(File1, .Range("A4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
    sCol = Application.Max(.Range("B5:B" & eRow))
    Arr2 = Get_Arr(File2, .Range("B4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
  End With
  Set Dic = CreateObject("scripting.dictionary")
 
  sRow = UBound(Arr1, 2)
  ReDim Res(1 To sRow + 3, 1 To 2 + srDK * 2)
  sCol = UBound(Res, 2) 'So cot Res
  For i = 0 To sRow
    maSo = Arr1(1, i)
    If maSo <> Empty Then
      If Dic.exists(maSo) = False Then
        Dic.Add maSo, i
        Res(i + 3, 1) = maSo
      End If
    End If
  Next i
 
  Res(2, 1) = "Ma so"
  For i = 1 To UBound(aDK)
    Res(1, i * 2) = "File 1"
    Res(2, i * 2) = aDK(i, 3): Res(2, i * 2 + 1) = aDK(i, 3)
  Next i
 
  sRow = UBound(Arr2, 2)
  For i = 0 To sRow
    maSo = Arr1(1, i)
    If Dic.exists(maSo) Then
      ik = Dic.Item(maSo)
      For j = 1 To srDK
        If j <> 2 Then
          If Arr1(aDK(j, 1) - 1, ik) <> Arr2(aDK(j, 2) - 1, i) Then
            Res(ik + 3, j * 2) = Arr1(aDK(j, 1) - 1, ik)
            Res(ik + 3, j * 2 + 1) = Arr2(aDK(j, 2) - 1, i)
            If Res(1, j * 2 + 1) = Empty Then Res(1, j * 2 + 1) = "File 2"
            If Res(ik + 3, sCol) = Empty Then Res(ik + 3, sCol) = "Ok"
          End If
        End If
      Next j
    End If
  Next i

  ReDim aCol(1 To 2, sCol \ 2)
  For j = 3 To sCol - 1 Step 2
    If Res(1, j) = "File 2" Then
      jC = jC + 1
      aCol(1, jC) = j - 1
      aCol(2, jC) = jC * 2
      Res(1, jC * 2 + 1) = "File 2"
      Res(2, jC * 2) = Res(2, j)
      Res(2, jC * 2 + 1) = Res(2, j)
    End If
  Next j
 
  sRow = UBound(Res)
  k = 2
  For i = 3 To sRow
    If Res(i, sCol) = "Ok" Then
      k = k + 1
      Res(k, 1) = Res(i, 1)
      For j = 1 To jC
        Res(k, aCol(2, j)) = Res(i, aCol(1, j))
        Res(k, aCol(2, j) + 1) = Res(i, aCol(1, j) + 1)
      Next j
    End If
  Next i
 
  With Sheets("Report")
    .UsedRange.ClearContents
    .Range("A2").Resize(k, aCol(2, jC) + 1) = Res
  End With
End Sub

Private Function Get_Arr(ByVal sFileName$, ByVal sAddress$) As Variant
  Dim cn As Object, rs As Object
  Set cn = CreateObject("ADODB.Connection")
  cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
  Set rs = cn.Execute("select * from [" & sAddress & "] where f1 is not null")
  If Not rs.EOF() Then Get_Arr = rs.GetRows
  rs.Close: cn.Close
  Set rs = Nothing: Set cn = Nothing
End Function
 

File đính kèm

  • Tong hop.xlsm
    22.7 KB · Đọc: 19
HieuCD đã viết:
Điều kiện so sánh nhập tay chính xác vào sheet DieuKien
Mã: 
Sub Main()
  Dim FSo As Object, Dic As Object
  Dim aDK(), Arr1, Arr2, aCol(), Res()
  Dim File1$, File2$, maSo$
  Dim eRow&, srDK&, sRow&, sCol&, j&, i&, ik&, jC&

  Set FSo = CreateObject("Scripting.FileSystemObject")
  With Sheets("DieuKien")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co dieu kien so sanh"): Exit Sub
    File1 = .Range("A2").Value
    If Right(File1, 1) <> "\" Then File1 = File1 & "\" & .Range("A3").Value Else File1 = File1 & .Range("A3").Value
    File2 = .Range("B2").Value
    If Right(File2, 1) <> "\" Then File2 = File2 & "\" & .Range("B3").Value Else File2 = File2 & .Range("B3").Value
    If FSo.FileExists(File1) = False Or FSo.FileExists(File2) = False Then MsgBox ("Ten Thu muc và File khong dung"): Exit Sub
    aDK = .Range("A5:C" & eRow).Value
    srDK = UBound(aDK) 'So dong bang dieu kien
    sCol = Application.Max(.Range("A5:A" & eRow))
    Arr1 = Get_Arr(File1, .Range("A4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
    sCol = Application.Max(.Range("B5:B" & eRow))
    Arr2 = Get_Arr(File2, .Range("B4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
  End With
  Set Dic = CreateObject("scripting.dictionary")

  sRow = UBound(Arr1, 2)
  ReDim Res(1 To sRow + 3, 1 To 2 + srDK * 2)
  sCol = UBound(Res, 2) 'So cot Res
  For i = 0 To sRow
    maSo = Arr1(1, i)
    If maSo <> Empty Then
      If Dic.exists(maSo) = False Then
        Dic.Add maSo, i
        Res(i + 3, 1) = maSo
      End If
    End If
  Next i

  Res(2, 1) = "Ma so"
  For i = 1 To UBound(aDK)
    Res(1, i * 2) = "File 1"
    Res(2, i * 2) = aDK(i, 3): Res(2, i * 2 + 1) = aDK(i, 3)
  Next i

  sRow = UBound(Arr2, 2)
  For i = 0 To sRow
    maSo = Arr1(1, i)
    If Dic.exists(maSo) Then
      ik = Dic.Item(maSo)
      For j = 1 To srDK
        If j <> 2 Then
          If Arr1(aDK(j, 1) - 1, ik) <> Arr2(aDK(j, 2) - 1, i) Then
            Res(ik + 3, j * 2) = Arr1(aDK(j, 1) - 1, ik)
            Res(ik + 3, j * 2 + 1) = Arr2(aDK(j, 2) - 1, i)
            If Res(1, j * 2 + 1) = Empty Then Res(1, j * 2 + 1) = "File 2"
            If Res(ik + 3, sCol) = Empty Then Res(ik + 3, sCol) = "Ok"
          End If
        End If
      Next j
    End If
  Next i

  ReDim aCol(1 To 2, sCol \ 2)
  For j = 3 To sCol - 1 Step 2
    If Res(1, j) = "File 2" Then
      jC = jC + 1
      aCol(1, jC) = j - 1
      aCol(2, jC) = jC * 2
      Res(1, jC * 2 + 1) = "File 2"
      Res(2, jC * 2) = Res(2, j)
      Res(2, jC * 2 + 1) = Res(2, j)
    End If
  Next j

  sRow = UBound(Res)
  k = 2
  For i = 3 To sRow
    If Res(i, sCol) = "Ok" Then
      k = k + 1
      Res(k, 1) = Res(i, 1)
      For j = 1 To jC
        Res(k, aCol(2, j)) = Res(i, aCol(1, j))
        Res(k, aCol(2, j) + 1) = Res(i, aCol(1, j) + 1)
      Next j
    End If
  Next i

  With Sheets("Report")
    .UsedRange.ClearContents
    .Range("A2").Resize(k, aCol(2, jC) + 1) = Res
  End With
End Sub

Private Function Get_Arr(ByVal sFileName$, ByVal sAddress$) As Variant
  Dim cn As Object, rs As Object
  Set cn = CreateObject("ADODB.Connection")
  cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
  Set rs = cn.Execute("select * from [" & sAddress & "] where f1 is not null")
  If Not rs.EOF() Then Get_Arr = rs.GetRows
  rs.Close: cn.Close
  Set rs = Nothing: Set cn = Nothing
End Function
Nhấp chuột vào đây để mở rộng...
Tuyệt quá ! :D
Nhưng có lẽ do ví dụ em đưa ra không sát thực tế nên trường hợp nếu thứ tự "Ma so" giữa 2 file khác nhau sẽ bị sai.
Anh có thể chỉnh lại giúp em được không ạ.
Xin lỗi anh!
 
bigbabol89 đã viết:
Tuyệt quá ! :D
Nhưng có lẽ do ví dụ em đưa ra không sát thực tế nên trường hợp nếu thứ tự "Ma so" giữa 2 file khác nhau sẽ bị sai.
Anh có thể chỉnh lại giúp em được không ạ.
Xin lỗi anh!
Nhấp chuột vào đây để mở rộng...
Thứ tự là điều kiện xét, bỏ luôn số thứ tự trong bảng điều kiện là ổn
 
Lần chỉnh sửa cuối:

File đính kèm

  • File 1.xlsx
    9.9 KB · Đọc: 9
  • File 2.xlsx
    9.2 KB · Đọc: 8
  • Tong hop.xlsm
    29.1 KB · Đọc: 6
bigbabol89 đã viết:
Dạ, ý em là "Ma so" ở 2 file nó không giống nhau ạ :

View attachment 248536
Nhấp chuột vào đây để mở rộng...
Chỉnh lại cách nhập bảng điều kiện
Mã: 
Sub Main()
  Dim FSo As Object, Dic As Object
  Dim aDK(), Arr1, Arr2, aCol(), Res()
  Dim File1$, File2$, maSo$
  Dim eRow&, srDK&, sRow&, sCol&, j&, i&, ik&, jC&, c1&, c2&
 
  Set FSo = CreateObject("Scripting.FileSystemObject")
  With Sheets("DieuKien")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co dieu kien so sanh"): Exit Sub
    File1 = .Range("A2").Value
    'File1 = ThisWorkbook.Path & "\"
    If Right(File1, 1) <> "\" Then File1 = File1 & "\" & .Range("A3").Value Else File1 = File1 & .Range("A3").Value
    File2 = .Range("B2").Value
    'File2 = ThisWorkbook.Path & "\"
    If Right(File2, 1) <> "\" Then File2 = File2 & "\" & .Range("B3").Value Else File2 = File2 & .Range("B3").Value
    If FSo.FileExists(File1) = False Or FSo.FileExists(File2) = False Then MsgBox ("Ten Thu muc và File khong dung"): Exit Sub
    aDK = .Range("A6:C" & eRow).Value
    srDK = UBound(aDK) 'So dong bang dieu kien
    c1 = .Range("A5").Value: c2 = .Range("B5").Value
    sCol = Application.Max(.Range("A5:A" & eRow))
    Arr1 = Get_Arr(File1, .Range("A4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
    sCol = Application.Max(.Range("B5:B" & eRow))
    Arr2 = Get_Arr(File2, .Range("B4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
  End With
  Set Dic = CreateObject("scripting.dictionary")
 
  sRow = UBound(Arr1, 2)
  ReDim Res(1 To sRow + 3, 1 To 2 + srDK * 2)
  sCol = UBound(Res, 2) 'So cot Res
  For i = 0 To sRow
    maSo = Arr1(c1 - 1, i)
    If maSo <> Empty Then
      If Dic.exists(maSo) = False Then
        Dic.Add maSo, i
        Res(i + 3, 1) = maSo
      End If
    End If
  Next i
 
  Res(2, 1) = "Ma so"
  For i = 1 To UBound(aDK)
    Res(1, i * 2) = "File 1"
    Res(2, i * 2) = aDK(i, 3): Res(2, i * 2 + 1) = aDK(i, 3)
  Next i
 
  sRow = UBound(Arr2, 2)
  For i = 0 To sRow
    maSo = Arr2(c2 - 1, i)
    If Dic.exists(maSo) Then
      ik = Dic.Item(maSo)
      For j = 1 To srDK
        If Arr1(aDK(j, 1) - 1, ik) <> Arr2(aDK(j, 2) - 1, i) Then
          Res(ik + 3, j * 2) = Arr1(aDK(j, 1) - 1, ik)
          Res(ik + 3, j * 2 + 1) = Arr2(aDK(j, 2) - 1, i)
          If Res(1, j * 2 + 1) = Empty Then Res(1, j * 2 + 1) = "File 2"
          If Res(ik + 3, sCol) = Empty Then Res(ik + 3, sCol) = "Ok"
        End If
      Next j
    End If
  Next i

  ReDim aCol(1 To 2, sCol \ 2)
  For j = 3 To sCol - 1 Step 2
    If Res(1, j) = "File 2" Then
      jC = jC + 1
      aCol(1, jC) = j - 1
      aCol(2, jC) = jC * 2
      Res(1, jC * 2 + 1) = "File 2"
      Res(2, jC * 2) = Res(2, j)
      Res(2, jC * 2 + 1) = Res(2, j)
    End If
  Next j
 
  sRow = UBound(Res)
  k = 2
  For i = 3 To sRow
    If Res(i, sCol) = "Ok" Then
      k = k + 1
      Res(k, 1) = Res(i, 1)
      For j = 1 To jC
        Res(k, aCol(2, j)) = Res(i, aCol(1, j))
        Res(k, aCol(2, j) + 1) = Res(i, aCol(1, j) + 1)
      Next j
    End If
  Next i
 
  With Sheets("Report")
    .UsedRange.ClearContents
    .Range("A2").Resize(k, aCol(2, jC) + 1) = Res
  End With
End Sub
 

File đính kèm

  • Tong hop (1).xlsm
    26.4 KB · Đọc: 18
HieuCD đã viết:
Chỉnh lại cách nhập bảng điều kiện
Mã: 
Sub Main()
  Dim FSo As Object, Dic As Object
  Dim aDK(), Arr1, Arr2, aCol(), Res()
  Dim File1$, File2$, maSo$
  Dim eRow&, srDK&, sRow&, sCol&, j&, i&, ik&, jC&, c1&, c2&

  Set FSo = CreateObject("Scripting.FileSystemObject")
  With Sheets("DieuKien")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co dieu kien so sanh"): Exit Sub
    File1 = .Range("A2").Value
    'File1 = ThisWorkbook.Path & "\"
    If Right(File1, 1) <> "\" Then File1 = File1 & "\" & .Range("A3").Value Else File1 = File1 & .Range("A3").Value
    File2 = .Range("B2").Value
    'File2 = ThisWorkbook.Path & "\"
    If Right(File2, 1) <> "\" Then File2 = File2 & "\" & .Range("B3").Value Else File2 = File2 & .Range("B3").Value
    If FSo.FileExists(File1) = False Or FSo.FileExists(File2) = False Then MsgBox ("Ten Thu muc và File khong dung"): Exit Sub
    aDK = .Range("A6:C" & eRow).Value
    srDK = UBound(aDK) 'So dong bang dieu kien
    c1 = .Range("A5").Value: c2 = .Range("B5").Value
    sCol = Application.Max(.Range("A5:A" & eRow))
    Arr1 = Get_Arr(File1, .Range("A4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
    sCol = Application.Max(.Range("B5:B" & eRow))
    Arr2 = Get_Arr(File2, .Range("B4").Value & "$A3:" & Cells(65000, sCol).address(0, 0))
  End With
  Set Dic = CreateObject("scripting.dictionary")

  sRow = UBound(Arr1, 2)
  ReDim Res(1 To sRow + 3, 1 To 2 + srDK * 2)
  sCol = UBound(Res, 2) 'So cot Res
  For i = 0 To sRow
    maSo = Arr1(c1 - 1, i)
    If maSo <> Empty Then
      If Dic.exists(maSo) = False Then
        Dic.Add maSo, i
        Res(i + 3, 1) = maSo
      End If
    End If
  Next i

  Res(2, 1) = "Ma so"
  For i = 1 To UBound(aDK)
    Res(1, i * 2) = "File 1"
    Res(2, i * 2) = aDK(i, 3): Res(2, i * 2 + 1) = aDK(i, 3)
  Next i

  sRow = UBound(Arr2, 2)
  For i = 0 To sRow
    maSo = Arr2(c2 - 1, i)
    If Dic.exists(maSo) Then
      ik = Dic.Item(maSo)
      For j = 1 To srDK
        If Arr1(aDK(j, 1) - 1, ik) <> Arr2(aDK(j, 2) - 1, i) Then
          Res(ik + 3, j * 2) = Arr1(aDK(j, 1) - 1, ik)
          Res(ik + 3, j * 2 + 1) = Arr2(aDK(j, 2) - 1, i)
          If Res(1, j * 2 + 1) = Empty Then Res(1, j * 2 + 1) = "File 2"
          If Res(ik + 3, sCol) = Empty Then Res(ik + 3, sCol) = "Ok"
        End If
      Next j
    End If
  Next i

  ReDim aCol(1 To 2, sCol \ 2)
  For j = 3 To sCol - 1 Step 2
    If Res(1, j) = "File 2" Then
      jC = jC + 1
      aCol(1, jC) = j - 1
      aCol(2, jC) = jC * 2
      Res(1, jC * 2 + 1) = "File 2"
      Res(2, jC * 2) = Res(2, j)
      Res(2, jC * 2 + 1) = Res(2, j)
    End If
  Next j

  sRow = UBound(Res)
  k = 2
  For i = 3 To sRow
    If Res(i, sCol) = "Ok" Then
      k = k + 1
      Res(k, 1) = Res(i, 1)
      For j = 1 To jC
        Res(k, aCol(2, j)) = Res(i, aCol(1, j))
        Res(k, aCol(2, j) + 1) = Res(i, aCol(1, j) + 1)
      Next j
    End If
  Next i

  With Sheets("Report")
    .UsedRange.ClearContents
    .Range("A2").Resize(k, aCol(2, jC) + 1) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Hoàn hảo rồi ạ.
Em cám ơn anh rất rất nhiều ạ.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

tby211
Lỗi 1004 vba khi tách file trắc nghiệm sang excel
Trả lời
0
Đọc
13
tby211
tby211
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
6
Đọc
138
NguyenthiH
NguyenthiH
test1986
  • Question
HELP! Sử dụng combobox để cập nhật dữ liệu trong file Excel
Trả lời
17
Đọc
505
ngochienbmt
N
N
Hàm if, lọc dữ liệu trùng
Trả lời
6
Đọc
6K
OANHMAI123
O
T
Xóa dòng theo điều kiện
Trả lời
1
Đọc
51
SA_DQ
SA_DQ
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom