Cần giúp đỡ Lọc bảng công nợ KH

[Ladybugx]

Em chào mọi người,
Em có bảng công nợ theo dõi KH đặt cọc và hoàn cọc, em muốn lấy bảng còn lại những món chưa hoàn cọc
Do một KH có thể đặt cọc nhiều lần nên khi hoàn cọc cũng phát sinh nhiều lần
Chi tiết em có chú thích trong file đính kèm.
Mong mn giúp đỡ em,
Em cảm ơn rất nhiều.

 

[dinhduy]

Bạn vào đây tham khảo nhé, ở bài 10, anh HieuCD có làm nè

https://www.giaiphapexcel.com/diendan/threads/file-d%C3%B9ng-c%C3%B4ng-th%E1%BB%A9c-m%E1%BA%A3ng-n%C3%AAn-ch%E1%BA%A1y-ch%E1%BA%ADm.160391/#post-1071326

 

[snow25]

Em chào mọi người,
Em có bảng công nợ theo dõi KH đặt cọc và hoàn cọc, em muốn lấy bảng còn lại những món chưa hoàn cọc
Do một KH có thể đặt cọc nhiều lần nên khi hoàn cọc cũng phát sinh nhiều lần
Chi tiết em có chú thích trong file đính kèm.
Mong mn giúp đỡ em,
Em cảm ơn rất nhiều.

Thử code hên sui.

Sub abc()
    Dim i As Long, lr As Long, data, arr, dic As Object, a As Long, c As Long, dk As String, j As Long, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A11:G" & lr).Value
         ReDim arr(1 To UBound(data), 1 To 7)
         ReDim kq(1 To UBound(data), 1 To 7)
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                dic.Add dk, a
                For j = 1 To 5
                    arr(a, j) = data(i, j)
                Next j
                If data(i, 7) = 2 Then
                   arr(a, 6) = -data(i, 6)
                Else
                   arr(a, 6) = data(i, 6)
                End If
              Else
                b = dic.Item(dk)
                If data(i, 7) = 2 Then
                   arr(b, 6) = arr(b, 6) - data(i, 6)
                Else
                   arr(b, 6) = arr(b, 6) + data(i, 6)
                End If
             End If
       Next i
       For i = 1 To a
           If arr(i, 6) > 0 Then
              c = c + 1
              For j = 1 To 6
                  kq(c, j) = arr(i, j)
              Next j
                  kq(c, 7) = 1
           ElseIf arr(i, 6) < 0 Then
              For j = 1 To 6
                  kq(c, j) = arr(i, j)
              Next j
                  kq(c, 7) = 2
           End If
      Next i
          .Range("K11:Q10000").ClearContents
          .Range("k11:Q11").Resize(c).Value = kq
   End With
    Set dic = Nothing
End Sub

 

[Ladybugx]

Thử code hên sui.

Sub abc()
    Dim i As Long, lr As Long, data, arr, dic As Object, a As Long, c As Long, dk As String, j As Long, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A11:G" & lr).Value
         ReDim arr(1 To UBound(data), 1 To 7)
         ReDim kq(1 To UBound(data), 1 To 7)
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                dic.Add dk, a
                For j = 1 To 5
                    arr(a, j) = data(i, j)
                Next j
                If data(i, 7) = 2 Then
                   arr(a, 6) = -data(i, 6)
                Else
                   arr(a, 6) = data(i, 6)
                End If
              Else
                b = dic.Item(dk)
                If data(i, 7) = 2 Then
                   arr(b, 6) = arr(b, 6) - data(i, 6)
                Else
                   arr(b, 6) = arr(b, 6) + data(i, 6)
                End If
             End If
       Next i
       For i = 1 To a
           If arr(i, 6) > 0 Then
              c = c + 1
              For j = 1 To 6
                  kq(c, j) = arr(i, j)
              Next j
                  kq(c, 7) = 1
           ElseIf arr(i, 6) < 0 Then
              For j = 1 To 6
                  kq(c, j) = arr(i, j)
              Next j
                  kq(c, 7) = 2
           End If
      Next i
          .Range("K11:Q10000").ClearContents
          .Range("k11:Q11").Resize(c).Value = kq
   End With
    Set dic = Nothing
End Sub

Dạ code chạy ngon lành ạ, nếu được anh có thể giúp em sửa code để kết quả lọc thể hiện từng dòng như bảng nguồn được k anh
Vd: Mã B412 sau khi lọc sẽ trả về những dòng mã 1, thay vì chỉ 1 dòng cho tổng số tiền

 

[johnnylinhanh]

Bạn ấn nút chạy xem thử, cái này bạn có thể thiết lập advance filter để làm mà nhỉ? Như vậy sẽ thuận tiện hơn cho bác xử lý các trường hợp tương tự sau này á.

 

[Ladybugx]

Bạn ấn nút chạy xem thử, cái này bạn có thể thiết lập advance filter để làm mà nhỉ? Như vậy sẽ thuận tiện hơn cho bác xử lý các trường hợp tương tự sau này á.

Ah bạn hiểu sai ý mình rồi, mình cần lọc lại những món chưa hoàn cọc (Sau khi đã trừ với món đã hoàn cọc của từng căn hộ thì Advanced Filter k được), code của bạn thì lọc ra tất cả món chưa hoàn cọc (mã 1)

 

[Ladybugx]

Thử code hên sui.

Sub abc()
    Dim i As Long, lr As Long, data, arr, dic As Object, a As Long, c As Long, dk As String, j As Long, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A11:G" & lr).Value
         ReDim arr(1 To UBound(data), 1 To 7)
         ReDim kq(1 To UBound(data), 1 To 7)
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                dic.Add dk, a
                For j = 1 To 5
                    arr(a, j) = data(i, j)
                Next j
                If data(i, 7) = 2 Then
                   arr(a, 6) = -data(i, 6)
                Else
                   arr(a, 6) = data(i, 6)
                End If
              Else
                b = dic.Item(dk)
                If data(i, 7) = 2 Then
                   arr(b, 6) = arr(b, 6) - data(i, 6)
                Else
                   arr(b, 6) = arr(b, 6) + data(i, 6)
                End If
             End If
       Next i
       For i = 1 To a
           If arr(i, 6) > 0 Then
              c = c + 1
              For j = 1 To 6
                  kq(c, j) = arr(i, j)
              Next j
                  kq(c, 7) = 1
           ElseIf arr(i, 6) < 0 Then
              For j = 1 To 6
                  kq(c, j) = arr(i, j)
              Next j
                  kq(c, 7) = 2
           End If
      Next i
          .Range("K11:Q10000").ClearContents
          .Range("k11:Q11").Resize(c).Value = kq
   End With
    Set dic = Nothing
End Sub

Dạ em cảm ơn anh lần nữa đã giúp đỡ, em có thể dùng được rồi.

Bài đã được tự động gộp: 26/5/22

Mình xin phép đóng bài, mình cảm ơn mn đã giúp đỡ.