Cách tách 01 cột số hiệu tài khoản, thành 02 cột tài khoản nợ và có

Liên hệ QC
chào các bạn giả sử nghiệp vụ đơn giản
- rút tiền gửi ngân hàng nhâp quỹ N111/C112
- phức tạp hơn chút mua hàng chưa trả tiền
N 152
N 133
C 331
thì phải làm ra 2 dòng
N152 C 331
N133 C 331
nhiều nghiêp vụ có 2 nợ 2 có,... thì làm thế nào các bạn
Vi phạm nguyên tắc hạch toán kế toán và yêu cầu tổ chức cơ sở dữ liệu, nên có thể làm được, hên xui
 
chào các bạn giả sử nghiệp vụ đơn giản
- rút tiền gửi ngân hàng nhâp quỹ N111/C112
- phức tạp hơn chút mua hàng chưa trả tiền
N 152
N 133
C 331
thì phải làm ra 2 dòng
N152 C 331
N133 C 331
nhiều nghiêp vụ có 2 nợ 2 có,... thì làm thế nào các bạn
Trường hợp nhiều hơn dạng 3 nợ 2 có thì việc tách này chắc phải tách tay rồi
 
Em cũng muốn chuyển nhật ký chung có 1 cột tài khoản thành 2 cột tài khoản.
Rất mong được anh HieuCD hỗ trợ.
Nếu dữ liệu chuẩn như ví dụ
Mã:
Sub NKC()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String
 
  Application.ScreenUpdating = False
  With Sheets("NKC2")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("A4:F" & i).Clear
    If i > 2 Then .Range("A3:F3").ClearContents
  End With
 
  With Sheets("NKC1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 1) <> sArr(i - 1, 1) Then fRow = i
    If sArr(i, 5) > 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    Else
      tkCo = sArr(i, 4)
    End If
    
    If sArr(i, 1) <> sArr(i + 1, 1) Then
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
      
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST > 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("NKC2")
    If k Then
      .Range("A3:F3").Resize(k) = Res
      If k > 1 Then
        .Range("A3:F3").Copy
        .Range("A3:F3").Resize(k).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
      End If
    End If
  End With
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • NKC_test.xlsm
    24.3 KB · Đọc: 122
bạn ơi chỉ mình cách chạy code này với, mình cũng gặp trường hợp tương tự mà không thể đưa nó về như cách bạn làm ý
 
bạn ơi chỉ mình cách chạy code này với, mình cũng gặp trường hợp tương tự mà không thể đưa nó về như cách bạn làm ý
bạn gửi file lên mọi người chạy hộ cho hoặc bấm alt+F11 hiện bảng rồi vào insert vào module rồi rán code vào F5 chạy là ok :D
 
Em có file này cũng cùng vấn đề là muốn chuyển thành 2 cột tài khoản nhưng dữ liệu nó lại lớn hớn thế nhiều nợ 1 có và nhiều có nhiều nợ
 

File đính kèm

  • 2-Nhat ky chung 2.xls
    1.9 MB · Đọc: 25
Nếu dữ liệu chuẩn như ví dụ
Mã:
Sub NKC()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String

  Application.ScreenUpdating = False
  With Sheets("NKC2")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("A4:F" & i).Clear
    If i > 2 Then .Range("A3:F3").ClearContents
  End With

  With Sheets("NKC1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 1) <> sArr(i - 1, 1) Then fRow = i
    If sArr(i, 5) > 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    Else
      tkCo = sArr(i, 4)
    End If
   
    If sArr(i, 1) <> sArr(i + 1, 1) Then
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
     
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST > 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("NKC2")
    If k Then
      .Range("A3:F3").Resize(k) = Res
      If k > 1 Then
        .Range("A3:F3").Copy
        .Range("A3:F3").Resize(k).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
      End If
    End If
  End With
  Application.ScreenUpdating = True
End Sub
Anh cho em hỏi anh dùng VBA đây phải không ạ, em chưa biết VBA em phải học ở đâu ạ, em cảm ơn anh!
 
Web KT
Back
Top Bottom