Lập sổ chi tiết theo tiểu mục bằng code VBA

gaucon671

Thành viên mới
Tham gia ngày
11 Tháng mười 2014
Bài viết
7
Được thích
3
Điểm
365
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 ạ.
 

File đính kèm

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,101
Được thích
11,241
Điểm
1,560
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 ạ.
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 Sub
 

File đính kèm

gaucon671

Thành viên mới
Tham gia ngày
11 Tháng mười 2014
Bài viết
7
Được thích
3
Điểm
365
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 Sub

dạ, 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 ạ.
 

File đính kèm

gaucon671

Thành viên mới
Tham gia ngày
11 Tháng mười 2014
Bài viết
7
Được thích
3
Điểm
365
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 Sub
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 ạ.
 

File đính kèm

Lần chỉnh sửa cuối:

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,101
Được thích
11,241
Điểm
1,560
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
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
 

gaucon671

Thành viên mới
Tham gia ngày
11 Tháng mười 2014
Bài viết
7
Được thích
3
Điểm
365
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 ạ
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,101
Được thích
11,241
Điểm
1,560
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 Sub
 

File đính kèm

gaucon671

Thành viên mới
Tham gia ngày
11 Tháng mười 2014
Bài viết
7
Được thích
3
Điểm
365
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 Sub
Dạ, code của Thầy ngắn hơn nhiều ạ. E cảm ơn Thầy nhiều lắm ạ. Hi.
 
Top Bottom