Lập báo cáo so sánh 2 files theo điều kiện (1 người xem)

bigbabol89 · 1/11/20

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ị !

bigbabol89 · 2/11/20

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 ạ

phuongvq123 · 2/11/20

bigbabol89 đã viết:
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 ạ

Chị yên tâm, có thể ngày mai sẽ có admin của nhóm trợ giúp

Cu Tồ · 3/11/20

Bài so sánh liệt kê này chắc chỉ dùng VBA thôi bạn ạ

Cu Tồ · 3/11/20

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ả.

ongke0711 · 3/11/20

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.

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])

HieuCD · 3/11/20

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ị !

Đ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

bigbabol89 · 3/11/20

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

Tuyệt quá !

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!

HieuCD · 3/11/20

bigbabol89 đã viết:
Tuyệt quá !
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!

Thứ tự là điều kiện xét, bỏ luôn số thứ tự trong bảng điều kiện là ổn

bigbabol89 · 3/11/20

HieuCD đã viết:
Thứ tự là điều kiện xét, bỏ luôn số thứ tự trong bảng điều kiện là ổn
Chú ý lệnh
If j <> 2 Then
với số 2 là thứ tự dòng của Mã số

Dạ, ý em là "Ma so" ở 2 file nó không giống nhau ạ :

HieuCD · 4/11/20

bigbabol89 đã viết:
Dạ, ý em là "Ma so" ở 2 file nó không giống nhau ạ :

View attachment 248536

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

bigbabol89 · 4/11/20

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

Hoàn hảo rồi ạ.
Em cám ơn anh rất rất nhiều ạ.

Lập báo cáo so sánh 2 files theo điều kiện (1 người xem)

Người dùng đang xem chủ đề này

bigbabol89

Thành viên thường trực

File đính kèm

bigbabol89

Thành viên thường trực

phuongvq123

Thành viên tiêu biểu

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

ongke0711

Thành viên gắn bó

HieuCD

Chuyên gia GPE

File đính kèm

bigbabol89

Thành viên thường trực

HieuCD

Chuyên gia GPE

bigbabol89

Thành viên thường trực

File đính kèm

HieuCD

Chuyên gia GPE

File đính kèm

bigbabol89

Thành viên thường trực

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

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

Đếm ngược thời gian