Kính gửi các anh/chị, e đang vướng về lập sổ chi tiết theo mã tiểu mục. E k biết cách làm sao để lấy ứng với từng tiểu mục sẽ có chi tiết tương ứng với tiểu mục đó ạ. E có data và kết quả mong muốn ở file đính kèm ạ. Anh/chị xem giúp e ạ. E cảm ơn ạ.
Lập sổ chi tiết theo tiểu mục bằng code VBA (2 người xem)
- Thread starter gaucon671
- Ngày gửi
Người dùng đang xem chủ đề này
Dùng code sự kiện
Mã:
Dim sArr(), eRowsArr&, sRow&
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Res(), S, TaiKhoan$, iKey
Dim eRow&, i&, k&, ik&, r&, iR&
If Target.Address = "$K$2" Then
Application.EnableEvents = False
Application.ScreenUpdating = False
eRow = Range("I" & Rows.Count).End(xlUp).Row
If eRow > 4 Then Range("H5:L" & eRow).Clear
TaiKhoan = Target.Value
If Len(TaiKhoan) > 0 Then
eRow = Range("A" & Rows.Count).End(xlUp).Row
If eRow < 2 Then GoTo Thoat
If eRow <> eRowsArr Then
eRowsArr = eRow
sArr = Range("A2:E" & eRowsArr).Value
sRow = UBound(sArr)
End If
ReDim Res(1 To sRow * 2, 1 To 5)
With CreateObject("scripting.dictionary")
For i = 1 To sRow
If CStr(sArr(i, 2)) = TaiKhoan Or CStr(sArr(i, 3)) = TaiKhoan Then
iKey = CStr(sArr(i, 4))
.Item(iKey) = .Item(iKey) & "," & i
End If
Next i
If .Count = 0 Then GoTo Thoat
For Each iKey In .keys
k = k + 1: ik = k
Res(ik, 1) = iKey: Res(ik + 1, 1) = iKey
S = Split(.Item(iKey), ",")
For r = 1 To UBound(S)
k = k + 1
iR = CLng(S(r))
Res(k, 2) = sArr(iR, 1)
If CStr(sArr(iR, 2)) = TaiKhoan Then
Res(k, 3) = sArr(iR, 3)
Res(k, 4) = sArr(iR, 5)
Res(ik, 4) = Res(ik, 4) + sArr(iR, 5)
Else
Res(k, 3) = sArr(iR, 2)
Res(k, 5) = sArr(iR, 5)
Res(ik, 5) = Res(ik, 5) + sArr(iR, 5)
End If
Next r
Next iKey
End With
Range("J5").Resize(k).NumberFormat = "@"
Range("H5").Resize(k, 5) = Res
Range("H5").Resize(k, 5).Borders.LineStyle = 1
End If
Thoat:
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Subdạ, e cảm ơn anh Hiếu @HieuCD nhiều lắm ạ. Anh có thể xem giúp e 1 vấn đề nữa là: e muốn có 1 dòng tổng cộng của phát sinh, sẽ là tổng của các dòng in đậm phía trên, thì e chỉnh code như thế nào ạ. E có đính kèm file bên dưới ạ. Anh xem giúp e ạ. E cảm ơn anh nhiều ạ.
Dạ, e có gửi lại file e làm kết quả ở sheet Bao cao từ ô W6:AF89. Thầy xem giúp e ạ. E cảm ơn Thầy @HieuCD ạ. Vì code e muốn ra kết quả phải làm 3 mudule nên em không biết còn cách nào có thể nhanh hơn k ạ. E cảm ơn ạ.
Lần chỉnh sửa cuối:
Bạn nói rỏ: File ban đầu có sheet nào? dữ liệu ở cột nào? sau khi xử lý kết quả lưu ở sheet nào? cột nào? mình sẽ viết lại toàn bộ code
Dạ, file ban đầu có sheet Data ạ: Dữ liệu từ A1:E2832 ạ. Kết quả em mong muốn ở sheet Bao cao từ W6:AF89 ạ, kết quả dữ liệu sẽ theo điều kiện tài khoản và từ ngày, đến ngày ạ
Tạo thêm sheet baocao để lưu kết quả
Mã:
Sub BaoCaoTaikhoan()
Dim i&, j&, r&, k&, iK&, iR&, Dcuoi&, SoDong&, SoDu As Double
Dim TuNgay As Date, DenNgay As Date, TaiKhoan$
Dim Arr_N(), Res(), Dic As Object, TieuMuc, S
With Sheet1
Dcuoi = .Range("a1000000").End(xlUp).Row
Arr_N = .Range("a2:j" & Dcuoi).Value
End With
SoDong = UBound(Arr_N, 1)
With Sheet4
Dcuoi = .Range("z1000000").End(xlUp).Row
If Dcuoi > 5 Then .Range("w6:ae" & Dcuoi).Clear
If Len(.Range("j1")) = 0 Or Len(.Range("j1")) = 0 Or Len(.Range("j1")) = 0 Then
MsgBox ("Du lieu dieu kien chua nhap"): Exit Sub
End If
On Error Resume Next
TuNgay = .Range("j1").Value
DenNgay = .Range("j2").Value
TaiKhoan = .Range("h1").Value
If Err.Number > 0 Or TuNgay > DenNgay Then
MsgBox ("Du lieu Thoi gian khong phu hop")
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
End With
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To SoDong
If CStr(Arr_N(i, 2)) = TaiKhoan Or CStr(Arr_N(i, 3)) = TaiKhoan Then
TieuMuc = CStr(Arr_N(i, 4))
If TieuMuc <> Empty Then
Dic.Item(TieuMuc) = Dic.Item(TieuMuc) & "," & i
End If
End If
Next i
If Dic.Count = 0 Then MsgBox ("Khong co du lieu phu hop"): Exit Sub
ReDim Res(1 To SoDong + Dic.Count + 1, 1 To 9)
k = 0
For Each TieuMuc In Dic.keys
k = k + 1
iK = k 'Dong Tong
Res(iK, 1) = TieuMuc: Res(iK + 1, 1) = TieuMuc
S = Split(Dic.Item(TieuMuc), ",")
For r = 1 To UBound(S)
iR = CLng(S(r))
If Arr_N(iR, 1) < TuNgay Then 'Du dau ky
If CStr(Arr_N(iR, 2)) = TaiKhoan Then 'Phat sinh No
Res(iK, 4) = Res(iK, 4) + Arr_N(iR, 5)
Else 'Phat sinh Co
Res(iK, 5) = Res(iK, 5) + Arr_N(iR, 5)
End If
Else 'Phat sinh trong ky
k = k + 1
Res(k, 2) = Arr_N(iR, 1)
If CStr(Arr_N(iR, 2)) = TaiKhoan Then 'Phat sinh No
Res(k, 3) = Arr_N(iR, 3)
Res(k, 6) = Arr_N(iR, 5)
Res(iK, 6) = Res(iK, 6) + Arr_N(iR, 5)
Else 'Phat sinh Co
Res(k, 3) = Arr_N(iR, 2)
Res(k, 7) = Arr_N(iR, 7)
Res(iK, 7) = Res(iK, 7) + Arr_N(iR, 5)
End If
End If
Next r
Next TieuMuc
Set Dic = Nothing
If k = 0 Then Exit Sub
Dcuoi = k + 1 'Dong tong cong
For i = 1 To k
If Res(i, 2) = Empty Then 'Dong Tong
SoDu = Res(i, 4) + Res(i, 6) - Res(i, 5) - Res(i, 7)
If SoDu > 0 Then
Res(i, 8) = SoDu
ElseIf SoDu < 0 Then
Res(i, 9) = -SoDu
End If
For j = 4 To 9
Res(Dcuoi, j) = Res(Dcuoi, j) + Res(i, j)
Next j
End If
Next i
SoDu = Res(Dcuoi, 4) - Res(Dcuoi, 5)
If SoDu > 0 Then
Res(Dcuoi, 4) = SoDu
Res(Dcuoi, 5) = Empty
Else
Res(Dcuoi, 5) = -SoDu
Res(Dcuoi, 4) = Empty
End If
SoDu = Res(Dcuoi, 8) - Res(Dcuoi, 9)
If SoDu > 0 Then
Res(Dcuoi, 8) = SoDu
Res(Dcuoi, 9) = Empty
Else
Res(Dcuoi, 9) = -SoDu
Res(Dcuoi, 8) = Empty
End If
With Sheet4
.Range("w6").Resize(Dcuoi).NumberFormat = "@"
.Range("y6").Resize(Dcuoi).NumberFormat = "@"
.Range("x6").Resize(Dcuoi).NumberFormat = "DD/MM/yyyy"
.Range("z6").Resize(Dcuoi, 6).NumberFormat = "#,###"
.Range("w6").Resize(Dcuoi, 9) = Res
.Range("w6").Resize(Dcuoi, 9).Borders.LineStyle = 1
End With
End SubDạ, code của Thầy ngắn hơn nhiều ạ. E cảm ơn Thầy nhiều lắm ạ. Hi.
