Giải quyết bài toán công nợ dò tìm

[tnfsmith]

Chào anh em, mình có file công nợ nhờ anh em xem hộ.
Chi tiết như file đính kèm.
Mình đã dùm hàm dò tìm nhưng kết quả không như ý, nhờ các cao thủ hỗ trợ thêm
Cám ơn anh em!

 

[PacificPR]

Chào anh em, mình có file công nợ nhờ anh em xem hộ.
Chi tiết như file đính kèm.
Mình đã dùm hàm dò tìm nhưng kết quả không như ý, nhờ các cao thủ hỗ trợ thêm
Cám ơn anh em!

Bạn thử chạy Code này thử:

Public Sub Tong_Ngay_thang()
    Dim sArr, dArr, tArr, Arr
    Dim Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long
    Dim Ngay As Long, Thang As Long, R As Long, Col As Long
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheet2
    tArr = .Range("B3:M3")
    Arr = .Range("A4", .Range("A65535").End(3))
    For J = 1 To UBound(tArr, 2)
        Dic1.Item(tArr(1, J)) = J
    Next J
    For I = 1 To UBound(Arr)
        Dic2.Item(Arr(I, 1)) = I
    Next I
End With
With Sheets("Data")
    sArr = .Range("A2", .Range("A65535").End(xlUp)).Resize(, 3).Value
End With
ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(tArr, 2))
For I = 1 To UBound(sArr, 1)
    Ngay = Day(sArr(I, 1)): Thang = Month(sArr(I, 1))
    R = Dic2.Item(Ngay): Col = Dic1.Item(Thang)
    If Not Dic2.Exists(Ngay) Then
        K = K + 1
        dArr(R, Col) = sArr(I, 3)
    Else
        dArr(R, Col) = dArr(R, Col) + sArr(I, 3)
    End If
Next I
Sheet2.Range("B4").Resize(UBound(Arr), UBound(tArr, 2)) = dArr
Set Dic1 = Nothing
Set Dic2 = Nothing
End Sub

 

[tnfsmith]

Lỗi Out of Range

Else
        dArr(R, Col) = dArr(R, Col) + sArr(I, 3)
    End If

 

[PacificPR]

Lỗi Out of Range

Else
        dArr(R, Col) = dArr(R, Col) + sArr(I, 3)
    End If

Vậy máy bạn nó Ghét Code của mình lên nó mới bị vậy

 

[tnfsmith]

Mình chỉnh lại vùng dữ liệu cho phù hợp thì nó bị vậy. Không hiểu nữa, mình edit lại như thế này:

Public Sub Tong_Ngay_thang()
    Dim sArr(), dArr(), tArr, Arr
    Dim Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long, Tem As String
    Dim Ngay As Long, Thang As Long, R As Long, Col As Long
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheet2
    tArr = .Range("B9:M9")
    Arr = .Range("A10", .Range("A65535").End(3))
    For J = 1 To UBound(tArr, 2)
        Dic1.Item(tArr(1, J)) = J
    Next J
    For I = 1 To UBound(Arr)
        Dic2.Item(Arr(I, 1)) = I
    Next I
End With
With Sheets("Data")
    sArr = .Range("S2", .Range("S65535").End(xlUp)).Resize(, 3).Value
End With
ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(tArr, 2))
For I = 1 To UBound(sArr, 1)
    Ngay = Day(sArr(I, 1)): Thang = Month(sArr(I, 1))
    R = Dic2.Item(Ngay): Col = Dic1.Item(Thang)
    If Not Dic2.Exists(Ngay) Then
        K = K + 1
        dArr(R, Col) = sArr(I, 3)
    Else
        dArr(R, Col) = dArr(R, Col) + sArr(I, 3)
    End If
Next I
Sheet2.Range("B10").Resize(UBound(Arr), UBound(tArr, 2)) = dArr
Set Dic1 = Nothing
Set Dic2 = Nothing
End Sub

Bạn xem dùm mình được không?

 

[PacificPR]

Thay lại Tháng 1 đến tháng 12 bên Bảng theo dõi công nợ là dạng số là được. Bạn xem file mình đính kèm đó

 

[tnfsmith]

Ok thanks bạn mình đã làm được.

 

[tnfsmith]

File còn lỗi chỗ Sheet2 nếu vba xóa các dòng sau ngày thứ 31. Mình muốn giữ lại vùng này để đưa thêm dữ liệu
Trong file đính kèm các dòng sau ngày thứ 31 đều phải giữ lại.
Cám ơn bạn nhiều!

 

[PacificPR]

File còn lỗi chỗ Sheet2 nếu vba xóa các dòng sau ngày thứ 31. Mình muốn giữ lại vùng này để đưa thêm dữ liệu
Trong file đính kèm các dòng sau ngày thứ 31 đều phải giữ lại.
Cám ơn bạn nhiều!

Bạn thử sửa cái này

Sheet2.Range("B10").Resize(UBound(Arr), UBound(tArr, 2)) = dArr ​

thành

Sheet2.Range("B10").Resize(31, UBound(tArr, 2)) = dArr​

Xem sao

 

[befaint]

Cứ tưởng cần dùng tới 2 Dic nên tò mò...
Bài này chỉ là dò tìm.
Công thức:

B4=IFERROR(LOOKUP(2,1/(Data!$F$2:$F$63=$A4)/(Data!$D$2:$D$63=COLUMN(A$1)),Data!$C$2:$C$63),"")

VBA:

Sub CongNo()
Dim Arr, Result(1 To 31, 1 To 12), i As Long, m As Long, d As Long
Arr = Sheet1.Range("C2:F63").Value
For i = 1 To UBound(Arr, 1)
    m = CLng(Arr(i, 2))
    d = CLng(Arr(i, 4))
    Result(d, m) = Arr(i, 1)
Next i
Sheet3.Range("B4").Resize(31, 12) = Result
End Sub