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

Liên hệ QC
G

gaucon671

Thành viên mới
Tham gia
11/10/14
Bài viết
7
Được thích
3
Giới tính
Nữ
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

  • bao cao.xlsx
    9.7 KB · Đọc: 13
gaucon671 đã viết:
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 ạ.
Nhấp chuột vào đây để mở rộng...
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

  • bao cao.xlsm
    18.4 KB · Đọc: 15
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...


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

  • bao cao.xlsm
    18.3 KB · Đọc: 10
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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

  • bao cao 01 - hoan thanh 03.xlsm
    196.2 KB · Đọc: 7
Lần chỉnh sửa cuối:
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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 ạ
 
gaucon671 đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
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

  • bao cao 01 - hoan thanh 03.xlsm
    209.4 KB · Đọc: 13
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...

Dạ, code của Thầy ngắn hơn nhiều ạ. E cảm ơn Thầy nhiều lắm ạ. Hi.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

A
[Cần Giúp] Excel nhiều người dùng cùng lúc
Trả lời
2
Đọc
20
befaint
befaint
NguyenNhan789556
Viết code trong VBA
Trả lời
2
Đọc
3
NguyenNhan789556
NguyenNhan789556
NguyenNhan789556
  • Question
Viết code trong VBA
Trả lời
0
Đọc
1
NguyenNhan789556
NguyenNhan789556
tby211
Lỗi 1004 vba khi tách file trắc nghiệm sang excel
Trả lời
3
Đọc
43
HUONGHCKT
H
hongphuong1997
  • Question
Lấy ký tự trong chuỗi theo nhiều điều kiện
Trả lời
2
Đọc
68
hongphuong1997
hongphuong1997
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom