Làm sổ chi tiết công nợ bằng VBA như thế nào

Liên hệ QC
minhcong.tckt

minhcong.tckt

Thành viên thường trực
Tham gia
13/4/11
Bài viết
385
Được thích
36
Giới tính
Nam
Em gửi file đính kèm, mong anh chị trong diễn đàn giúp đỡ.
Sheet "NKC": Nơi cập nhật chứng từ theo hình thức nhật ký chung
Sheet "SCTCN": Sổ chi tiết công nợ
Giờ em muốn anh chị thêm code cho sheet "SCTCN" để khi mình đánh mã Tài khoản vào ô D6 và mã khách vào ô D7 thì sổ chi tiết công nợ tương ứng với khách hàng hiện ra (Có vẽ khung viền bảng biểu)
File em gửi là em lấy từ trên mạng về nên chỗ nào thêm code vào anh chị nói rõ cho em hiểu luôn nhé.

Chân thành cảm ơn!!!
 

File đính kèm

  • Trich Loc So Cai Bang ForNext.rar
    18.4 KB · Đọc: 370
Sắp xếp theo thời gian sắp xếp theo bầu chọn
minhcong.tckt đã viết:
Tại "NKC" mình thay cột ngày tháng (Cột B) bằng cột "KH" thì tại " Sổ chi tiết công nợ" ấn vào nút thì báo lỗi
ThuNghi sửa lỗi cho mình với nhé

Chân thành cảm ơn
Nhấp chuột vào đây để mở rộng...
Sửa trong phần đầu code
PHP: 
Const cNg = 2
thành
PHP: 
Const cNg = 4
Lý do là bạn sửa cấu trúc sh NKC ngày HT là cột 2 thành cột 4 nên code kg hiểu.
 
Upvote 0
concogia đã viết:
À há !!! hiểu rồi, còn làm trúng trật là ....hên xui thôi
Cột P & Q ở sheet "NKC" là 2 cột mình tạo mã Tài Khoản & Khách hàng cho bạn, nếu có cập nhật thêm thì cứ nhập bình thường trong bảng rồi bấm Ctrl + Q code sẽ cập nhật bỏ vào Validation ở D6 & D7 sheet "SCTCN"
Ở sheet "SCTCN" bạn chọn dữ liệu ở D6 & D7 rồi xem kết quả
Thân
Nhấp chuột vào đây để mở rộng...
"Tải file đính kèm tại #5"
Anh ơi cho em hỏi, nếu Cột Mã Khách là cột L chứ ko phải cột I thì sửa code như thế nào
Có phải sửa
If Vung(i, 5) = [D6] And Vung(i, 11) = [D7] Then
Nhấp chuột vào đây để mở rộng...
thay vì 8 ??? em thay thành 11 thì code báo lỗi.
Mong anh giúp đỡ
 
Lần chỉnh sửa cuối:
Upvote 0
nhờ các bác giúp. do em gộp chung mã khách hàng vào trong 2 cột định khoản là bằng dấu # (ví dụ: 131#BaoV; 331#ThangL...) còn nhưng tài khoản kia vẫn dùng bình thường, em đã áp dụng được vào sổ chi tiết khách hàng bằng cách bỏ điều kiện mã khách hàng, nhưng khi dùng mã này để chạy thêm 1 sổ chi tiết tài khoản, thì em muốn dùng điều kiện là những tài khoản trước dấu "#" để lên sổ chi tiết tài khoản thì phải sửa lệnh như nào ạ. em định dùng hàm left nhưng em có những tài khoản loại 1 có 3 ký tự, loại 2 có 4 ký tự, loại 3 có 5 ký tự ... nên không khả thi lắm ạ.
 
Upvote 0
Bài gần nhất cách đây cũng đã hơn 7 năm, nên:
Bạn nên dẫn ra file đang ở bài nào trong mớ các bài trên
Hay là đưa file giả lập lên
Hoặc Mua chục li cà fê & nhâm nhi hết số đó may ra . . . . có người trong ngành hỗ trợ bạn!

Chúc ngày cuối tuần vui vẻ!
 
Upvote 0
SA_DQ đã viết:
Bài gần nhất cách đây cũng đã hơn 7 năm, nên:
Bạn nên dẫn ra file đang ở bài nào trong mớ các bài trên
Hay là đưa file giả lập lên
Hoặc Mua chục li cà fê & nhâm nhi hết số đó may ra . . . . có người trong ngành hỗ trợ bạn!

Chúc ngày cuối tuần vui vẻ!
Nhấp chuột vào đây để mở rộng...
dạ vâng ạ. hy vong mọi người giúp em với ạ!
 

File đính kèm

  • SoCT.xlsm
    37 KB · Đọc: 21
Upvote 0
theanhst92 đã viết:
dạ vâng ạ. hy vong mọi người giúp em với ạ!
Nhấp chuột vào đây để mở rộng...
Dùng Left(Tài khoản chi tiết,Len(TK cấp trên)) = TK cấp trên
M7 nhập '131
Mã: 
Option Explicit
Dim endR&, fD&, eD&, i&, s&, k&, sokytuTK&
Dim sTK$, sMaKH$, tkNo$, tkCo$
Dim SoDu As Double
Dim Arr(), ArrKQ()
Const cNg = 2: Const cTkNo = 7: Const cTkCo = 8: Const cST = 9
Sub TaoSoCT()
With Sheets("NLPS")
  .AutoFilterMode = False
  endR = .Cells(65000, 2).End(3).Row
  Arr = .Range("A6:J" & endR).Value 'Arr la vung du lieu
End With
With Sheets("SCTTK")
  .Rows("13:200").EntireRow.Hidden = False
  .Range("C13:I200").ClearContents
  .[H12] = 0: .[I12] = 0
  fD = CLng(.[M5]):  eD = CLng(.[M6])
  sTK = CStr(.[M7]): sokytuTK = Len(sTK)
End With
s = 0: SoDu = 0
ReDim ArrKQ(1 To 200, 1 To 7)
For i = 1 To UBound(Arr)
    tkNo = Left(Arr(i, cTkNo), sokytuTK)
    tkCo = Left(Arr(i, cTkCo), sokytuTK)
    If tkNo = sTK Or tkCo = sTK Then
      If CLng(Arr(i, cNg)) <= eD Then
        Select Case fD
          Case Is > CLng(Arr(i, cNg)) 'Sodu
            Select Case sTK
              Case Is = tkNo
                SoDu = SoDu + Arr(i, cST)
              Case Is = tkCo
                SoDu = SoDu - Arr(i, cST)
            End Select
          Case Is <= CLng(Arr(i, cNg)) 'PS
            s = s + 1
            For k = 1 To 4
              ArrKQ(s, k) = Arr(i, k + 1)
            Next k
            Select Case sTK
              Case Is = tkNo 'PSNo
                ArrKQ(s, 5) = Arr(i, cTkCo)
                ArrKQ(s, 6) = Arr(i, cST) 'ST PS No
              Case Is = tkCo 'PSCo
                ArrKQ(s, 5) = Arr(i, cTkNo)
                ArrKQ(s, 7) = Arr(i, cST) 'STPS Co
            End Select
        End Select
      End If
    End If
Next i
If s = 0 Then
  MsgBox "Kg co"
  GoTo Exit_Sub
End If
With Sheets("SCTTK")
 .Rows(s + 14 & ":200").EntireRow.Hidden = True
  If SoDu > 0 Then
    .[H12] = SoDu: .[I12] = 0
  Else
    .[I12] = -SoDu: .[H12] = 0
  End If
 '.Range("A11:G200").ClearContents
 .[C13].Resize(s, 7) = ArrKQ
End With
Exit_Sub:
Erase Arr(), ArrKQ()
End Sub
 
Upvote 0
HieuCD đã viết:
Dùng Left(Tài khoản chi tiết,Len(TK cấp trên)) = TK cấp trên
M7 nhập '131
Mã: 
Option Explicit
Dim endR&, fD&, eD&, i&, s&, k&, sokytuTK&
Dim sTK$, sMaKH$, tkNo$, tkCo$
Dim SoDu As Double
Dim Arr(), ArrKQ()
Const cNg = 2: Const cTkNo = 7: Const cTkCo = 8: Const cST = 9
Sub TaoSoCT()
With Sheets("NLPS")
  .AutoFilterMode = False
  endR = .Cells(65000, 2).End(3).Row
  Arr = .Range("A6:J" & endR).Value 'Arr la vung du lieu
End With
With Sheets("SCTTK")
  .Rows("13:200").EntireRow.Hidden = False
  .Range("C13:I200").ClearContents
  .[H12] = 0: .[I12] = 0
  fD = CLng(.[M5]):  eD = CLng(.[M6])
  sTK = CStr(.[M7]): sokytuTK = Len(sTK)
End With
s = 0: SoDu = 0
ReDim ArrKQ(1 To 200, 1 To 7)
For i = 1 To UBound(Arr)
    tkNo = Left(Arr(i, cTkNo), sokytuTK)
    tkCo = Left(Arr(i, cTkCo), sokytuTK)
    If tkNo = sTK Or tkCo = sTK Then
      If CLng(Arr(i, cNg)) <= eD Then
        Select Case fD
          Case Is > CLng(Arr(i, cNg)) 'Sodu
            Select Case sTK
              Case Is = tkNo
                SoDu = SoDu + Arr(i, cST)
              Case Is = tkCo
                SoDu = SoDu - Arr(i, cST)
            End Select
          Case Is <= CLng(Arr(i, cNg)) 'PS
            s = s + 1
            For k = 1 To 4
              ArrKQ(s, k) = Arr(i, k + 1)
            Next k
            Select Case sTK
              Case Is = tkNo 'PSNo
                ArrKQ(s, 5) = Arr(i, cTkCo)
                ArrKQ(s, 6) = Arr(i, cST) 'ST PS No
              Case Is = tkCo 'PSCo
                ArrKQ(s, 5) = Arr(i, cTkNo)
                ArrKQ(s, 7) = Arr(i, cST) 'STPS Co
            End Select
        End Select
      End If
    End If
Next i
If s = 0 Then
  MsgBox "Kg co"
  GoTo Exit_Sub
End If
With Sheets("SCTTK")
.Rows(s + 14 & ":200").EntireRow.Hidden = True
  If SoDu > 0 Then
    .[H12] = SoDu: .[I12] = 0
  Else
    .[I12] = -SoDu: .[H12] = 0
  End If
'.Range("A11:G200").ClearContents
.[C13].Resize(s, 7) = ArrKQ
End With
Exit_Sub:
Erase Arr(), ArrKQ()
End Sub
Nhấp chuột vào đây để mở rộng...
Nếu dùng như vậy thì bí dụ khi em cần chi tiết tài khoản 1111 hay là 13881 thì lại phải chỉnh lại mã này ạ
 
Upvote 0
HieuCD đã viết:
Mình chỉ chỉnh code cho chạy đúng theo bài #23, không can thiệp cách chạy code thế nào
Nhấp chuột vào đây để mở rộng...
dạ vâng. tại em cũng đã dùng hàm left để lấy điều kiện của biến theo số ký tự cần dùng rồi, nhưng do tài khoản có nhiều cấp nên thành ra phát sinh như vậy, có cách nào để tách ký tự sau dấu # ra khỏi điều kiện không ạ.
 
Upvote 0
theanhst92 đã viết:
dạ vâng. tại em cũng đã dùng hàm left để lấy điều kiện của biến theo số ký tự cần dùng rồi, nhưng do tài khoản có nhiều cấp nên thành ra phát sinh như vậy, có cách nào để tách ký tự sau dấu # ra khỏi điều kiện không ạ.
Nhấp chuột vào đây để mở rộng...
" có cách nào để tách ký tự sau dấu # ra khỏi điều kiện" nói rỏ hơn của vùng dữ liệu nào?
 
Upvote 0
HieuCD đã viết:
Code mình đã tách rồi mờ
Nhấp chuột vào đây để mở rộng...
dạ đúng ý em rồi ạ. tại xem mã k để ý thành ra viết lại k đúng như bác sửa cho. em cảm ơn ạ

HieuCD đã viết:
" có cách nào để tách ký tự sau dấu # ra khỏi điều kiện" nói rỏ hơn của vùng dữ liệu nào?
Nhấp chuột vào đây để mở rộng...
vậy để tách chuỗi sau ký tự "#" thì viết như nào ạ. nhờ bác chỉ giúp em với ạ.
 
Upvote 0
em có sửa một chút để dùng mã này copy dữ liệu. nhưng do muốn tách mã chi tiết trong định khoản ra để dùng làm biến nên chưa nghĩ ra hướng làm. đành thêm vào điều kiện cụ thể là
If CStr("331#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
Or CStr("3383#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
Or CStr("131#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) Then
nhưng như vậy nếu phát sinh khác có lẽ không khả thi lắm. nhờ bác giúp em ạ
Mã: 
Sub UNC_AGR()
With Sheets("NLPS")
  .AutoFilterMode = False
  endR = .Cells(65000, 2).End(3).Row
  Arr = .Range("A6:U" & endR).Value
End With
With Sheets("DSKH")
  .AutoFilterMode = False
  DSKH = .Range("A3:J" & endR).Value
End With
With Sheets("UNC_AGR")
'  .Rows("72:90").EntireRow.Hidden = False
  .Range("T80:AH90").ClearContents
  sTK = CStr(.[T7])
End With
S = 0
ReDim ArrKQ(1 To 10, 1 To 8)
For i = 1 To UBound(Arr)
SCtu = CStr(Arr(i, cSoCT))
    If SCtu = sTK Then
            S = S + 1
            For K = 1 To 8
              ArrKQ(S, K) = Arr(i, K + 1)
            Next K
    End If
Next i
R = 0
ReDim dskhKQ(1 To 10, 1 To 6)
For i = 1 To UBound(DSKH)
    If CStr("331#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
    Or CStr("3383#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
    Or CStr("131#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) Then
        R = R + 1
        For K = 1 To 6
            dskhKQ(R, K) = DSKH(i, K + 1)
        Next K
    End If
Next i
If S = 0 Then
  MsgBox (CHUYENMA("So phieu khong hop le"))
  GoTo Exit_Sub
End If
If R = 0 Then
  MsgBox (CHUYENMA("Chua co ma khach hang"))
  GoTo Exit_Sub
End If
With Sheets("UNC_AGR")
' .Rows(S + 82 & ":90").EntireRow.Hidden = True
 .[T80].Resize(S, 8) = ArrKQ
 .[AB80].Resize(R, 6) = dskhKQ
End With
Exit_Sub:
Erase Arr(), ArrKQ(), dskhKQ()
End Sub
 
Upvote 0
theanhst92 đã viết:
em có sửa một chút để dùng mã này copy dữ liệu. nhưng do muốn tách mã chi tiết trong định khoản ra để dùng làm biến nên chưa nghĩ ra hướng làm. đành thêm vào điều kiện cụ thể là
If CStr("331#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
Or CStr("3383#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
Or CStr("131#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) Then
nhưng như vậy nếu phát sinh khác có lẽ không khả thi lắm. nhờ bác giúp em ạ
Mã: 
Sub UNC_AGR()
With Sheets("NLPS")
  .AutoFilterMode = False
  endR = .Cells(65000, 2).End(3).Row
  Arr = .Range("A6:U" & endR).Value
End With
With Sheets("DSKH")
  .AutoFilterMode = False
  DSKH = .Range("A3:J" & endR).Value
End With
With Sheets("UNC_AGR")
'  .Rows("72:90").EntireRow.Hidden = False
  .Range("T80:AH90").ClearContents
  sTK = CStr(.[T7])
End With
S = 0
ReDim ArrKQ(1 To 10, 1 To 8)
For i = 1 To UBound(Arr)
SCtu = CStr(Arr(i, cSoCT))
    If SCtu = sTK Then
            S = S + 1
            For K = 1 To 8
              ArrKQ(S, K) = Arr(i, K + 1)
            Next K
    End If
Next i
R = 0
ReDim dskhKQ(1 To 10, 1 To 6)
For i = 1 To UBound(DSKH)
    If CStr("331#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
    Or CStr("3383#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) _
    Or CStr("131#" & DSKH(i, cMaKH)) = ArrKQ(1, 6) Then
        R = R + 1
        For K = 1 To 6
            dskhKQ(R, K) = DSKH(i, K + 1)
        Next K
    End If
Next i
If S = 0 Then
  MsgBox (CHUYENMA("So phieu khong hop le"))
  GoTo Exit_Sub
End If
If R = 0 Then
  MsgBox (CHUYENMA("Chua co ma khach hang"))
  GoTo Exit_Sub
End If
With Sheets("UNC_AGR")
' .Rows(S + 82 & ":90").EntireRow.Hidden = True
.[T80].Resize(S, 8) = ArrKQ
.[AB80].Resize(R, 6) = dskhKQ
End With
Exit_Sub:
Erase Arr(), ArrKQ(), dskhKQ()
End Sub
Nhấp chuột vào đây để mở rộng...
Không có file nên không biết Sheets("UNC_AGR") có gì trong đó, rủi có người đẹp trong đó thì mệt lắm
 
Upvote 0
theanhst92 đã viết:
dạ em xin gửi file cụ thể ạ.
Nhấp chuột vào đây để mở rộng...
Chỉnh code
Mã: 
Sub TaoSoCT()
With Sheets("NLPS")
  .AutoFilterMode = False
  endR = .Cells(65000, 2).End(3).Row
  Arr = .Range("A6:J" & endR).Value 'Arr la vung du lieu
End With
With Sheets("SCTTK")
  .Rows("13:200").EntireRow.Hidden = False
  .Range("C13:I200").ClearContents
  .[H12] = 0: .[I12] = 0
  fD = CLng(.[M5]):  eD = CLng(.[M6])
  sTK = CStr(.[M7])
  If InStr(1, sTK, "#") > 0 Then
    sTK = Mid(sTK, 1, InStr(1, sTK, "#") - 1)
  End If
  sokytuTK = Len(sTK)
End With
S = 0: SoDu = 0
ReDim ArrKQ(1 To 200, 1 To 7)
For i = 1 To UBound(Arr)
    TkNo = Left(Arr(i, cTkNo), sokytuTK)
    TkCo = Left(Arr(i, cTkCo), sokytuTK)
    If TkNo = sTK Or TkCo = sTK Then
      If CLng(Arr(i, cNg)) <= eD Then
        Select Case fD
          Case Is > CLng(Arr(i, cNg)) 'Sodu
            Select Case sTK
              Case Is = TkNo
                SoDu = SoDu + Arr(i, cST)
              Case Is = TkCo
                SoDu = SoDu - Arr(i, cST)
            End Select
          Case Is <= CLng(Arr(i, cNg)) 'PS
            S = S + 1
            For K = 1 To 4
              ArrKQ(S, K) = Arr(i, K + 1)
            Next K
            Select Case sTK
              Case Is = TkNo 'PSNo
                ArrKQ(S, 5) = Arr(i, cTkCo)
                ArrKQ(S, 6) = Arr(i, cST) 'ST PS No
              Case Is = TkCo 'PSCo
                ArrKQ(S, 5) = Arr(i, cTkNo)
                ArrKQ(S, 7) = Arr(i, cST) 'STPS Co
            End Select
        End Select
      End If
    End If
Next i
If S = 0 Then
  MsgBox "Kg co"
  GoTo Exit_Sub
End If
With Sheets("SCTTK")
 .Rows(S + 14 & ":200").EntireRow.Hidden = True
  If SoDu > 0 Then
    .[H12] = SoDu: .[I12] = 0
  Else
    .[I12] = -SoDu: .[H12] = 0
  End If
 '.Range("A11:G200").ClearContents
 .[C13].Resize(S, 7) = ArrKQ
End With
Exit_Sub:
Erase Arr(), ArrKQ()
End Sub
Sub còn lại thiếu nhiều lệnh nên không biết làm gì. Gởi kết quả làm tay và mục đich code
 
Upvote 0
HieuCD đã viết:
Chỉnh code
Mã: 
Sub TaoSoCT()
With Sheets("NLPS")
  .AutoFilterMode = False
  endR = .Cells(65000, 2).End(3).Row
  Arr = .Range("A6:J" & endR).Value 'Arr la vung du lieu
End With
With Sheets("SCTTK")
  .Rows("13:200").EntireRow.Hidden = False
  .Range("C13:I200").ClearContents
  .[H12] = 0: .[I12] = 0
  fD = CLng(.[M5]):  eD = CLng(.[M6])
  sTK = CStr(.[M7])
  If InStr(1, sTK, "#") > 0 Then
    sTK = Mid(sTK, 1, InStr(1, sTK, "#") - 1)
  End If
  sokytuTK = Len(sTK)
End With
S = 0: SoDu = 0
ReDim ArrKQ(1 To 200, 1 To 7)
For i = 1 To UBound(Arr)
    TkNo = Left(Arr(i, cTkNo), sokytuTK)
    TkCo = Left(Arr(i, cTkCo), sokytuTK)
    If TkNo = sTK Or TkCo = sTK Then
      If CLng(Arr(i, cNg)) <= eD Then
        Select Case fD
          Case Is > CLng(Arr(i, cNg)) 'Sodu
            Select Case sTK
              Case Is = TkNo
                SoDu = SoDu + Arr(i, cST)
              Case Is = TkCo
                SoDu = SoDu - Arr(i, cST)
            End Select
          Case Is <= CLng(Arr(i, cNg)) 'PS
            S = S + 1
            For K = 1 To 4
              ArrKQ(S, K) = Arr(i, K + 1)
            Next K
            Select Case sTK
              Case Is = TkNo 'PSNo
                ArrKQ(S, 5) = Arr(i, cTkCo)
                ArrKQ(S, 6) = Arr(i, cST) 'ST PS No
              Case Is = TkCo 'PSCo
                ArrKQ(S, 5) = Arr(i, cTkNo)
                ArrKQ(S, 7) = Arr(i, cST) 'STPS Co
            End Select
        End Select
      End If
    End If
Next i
If S = 0 Then
  MsgBox "Kg co"
  GoTo Exit_Sub
End If
With Sheets("SCTTK")
.Rows(S + 14 & ":200").EntireRow.Hidden = True
  If SoDu > 0 Then
    .[H12] = SoDu: .[I12] = 0
  Else
    .[I12] = -SoDu: .[H12] = 0
  End If
'.Range("A11:G200").ClearContents
.[C13].Resize(S, 7) = ArrKQ
End With
Exit_Sub:
Erase Arr(), ArrKQ()
End Sub
Sub còn lại thiếu nhiều lệnh nên không biết làm gì. Gởi kết quả làm tay và mục đich code
Nhấp chuột vào đây để mở rộng...
chết em quên mất là cái điều kiện em cần là ở sub sau, còn sub trước em làm theo bác hướng dẫn đuược rồi. :(
em xin gửi lại file có ghi rõ điều muốn, mong đc bác giúp thêm ạ
 

File đính kèm

  • SoCT (1).xlsm
    33 KB · Đọc: 15
Lần chỉnh sửa cuối:
Upvote 0
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

LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
    • Cười
2
Trả lời
28
Đọc
299
Hoàng Tuấn 868
H
L
Tạo hàm Round cho nhiều dòng
Trả lời
14
Đọc
6K
KenJayce
K
N
Giải pháp nào để gỡ bỏ hàm Round (là hàm ngoài cùng) trong tất cả các ô trong bảng?
Trả lời
8
Đọc
4K
KenJayce
K
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
7
Đọc
114
thaiquy7
T
ann266
Kế toán kho F&B
    • Cười
2
Trả lời
22
Đọc
250
le_vis
L
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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