Đánh số thứ tự nhiều điều kiện

kobebryant · 2/6/21

Diễn đàn cho mình xin code đặt tên phiếu thu/chi của data trộn lẫn Thu/Chi
Phiếu thu chi phụ thuộc vào 3 ký tự đầu "111" của 2 cột và Tên phiếu phụ thuộc vào Ngày chứng từ và Số chứng từ (Số chứng từ cái có, cái không).
Trong file đính kèm mình có diễn giải và kết quả mong muốn.
Xin cám ơn

Nhattanktnn · 3/6/21

kobebryant đã viết:
Diễn đàn cho mình xin code đặt tên phiếu thu/chi của data trộn lẫn Thu/Chi
Phiếu thu chi phụ thuộc vào 3 ký tự đầu "111" của 2 cột và Tên phiếu phụ thuộc vào Ngày chứng từ và Số chứng từ (Số chứng từ cái có, cái không).
Trong file đính kèm mình có diễn giải và kết quả mong muốn.
Xin cám ơn

Bạn cần làm rõ phần những đầu số như thế nào thì thuộc các loại : PT, PTCT,PC,PCCT

HieuCD · 3/6/21

kobebryant đã viết:
Diễn đàn cho mình xin code đặt tên phiếu thu/chi của data trộn lẫn Thu/Chi
Phiếu thu chi phụ thuộc vào 3 ký tự đầu "111" của 2 cột và Tên phiếu phụ thuộc vào Ngày chứng từ và Số chứng từ (Số chứng từ cái có, cái không).
Trong file đính kèm mình có diễn giải và kết quả mong muốn.
Xin cám ơn

Kết quả code khác tí

Mã:

Sub XYZ()
  Dim sArr(), Res()
  Dim sRow&, i&, thu&, thu2&, chi&, chi2&, ngay$, phieu$
 
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("H2") = 1
    .Range("H2:H" & i).DataSeries
    .Range("B2:I" & i).Sort .Range("B2"), 1, .Range("C2"), , 1, Header:=xlNo
    sArr = .Range("B1:G" & i).Value
    sRow = UBound(sArr)
    ReDim Res(2 To sRow, 1 To 1)
    For i = 2 To sRow
      If sArr(i, 2) = Empty Then
        If Mid(sArr(i, 5), 1, 3) = "111" Then
          thu = thu + 1
          Res(i, 1) = "PT" & Format(sArr(i, 1), "DDMMYY.") & thu
        ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
          chi = chi + 1
          Res(i, 1) = "PC" & Format(sArr(i, 1), "DDMMYY.") & chi
        End If
      Else
        If sArr(i, 1) <> sArr(i - 1, 1) Or sArr(i, 2) <> sArr(i - 1, 2) Then
          If Mid(sArr(i, 5), 1, 3) = "111" Then
            thu2 = thu2 + 1
            Res(i, 1) = "PTCT" & Format(sArr(i, 1), "DDMMYY.") & thu2
          ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
            chi2 = chi2 + 1
            Res(i, 1) = "PCCT" & Format(sArr(i, 1), "DDMMYY.") & chi2
          End If
        Else
          Res(i, 1) = Res(i - 1, 1)
        End If
      End If
    Next i
    .Range("A2").Resize(sRow - 1) = Res
    .Range("A2:I" & i).Sort .Range("H2"), 1, Header:=xlNo
    .Range("H2").Resize(sRow - 1) = Empty
  End With
  Application.ScreenUpdating = True
End Sub

kobebryant · 3/6/21

Nhattanktnn đã viết:
Bạn cần làm rõ phần những đầu số như thế nào thì thuộc các loại : PT, PTCT,PC,PCCT

3 ký tự đầu là "111"
- Nếu bên cột Nợ thì là PT, nếu có Số chứng từ thì là "PTCT", còn không có Số chứng từ thì là "PT"
- Nếu bên cột Có thì là PC, nếu có Số chứng từ thì là "PCCT", còn không có Số chứng từ thì là "PC"

Nhattanktnn · 3/6/21

kobebryant đã viết:
3 ký tự đầu là "111"
- Nếu bên cột Nợ thì là PT, nếu có Số chứng từ thì là "PTCT", còn không có Số chứng từ thì là "PT"
- Nếu bên cột Có thì là PC, nếu có Số chứng từ thì là "PCCT", còn không có Số chứng từ thì là "PC"

Mà nãy mình nhìn chưa kỹ, phần sau dấu chấm tính thế nào?

kobebryant · 3/6/21

Nhattanktnn đã viết:
Mà nãy mình nhìn chưa kỹ, phần sau dấu chấm tính thế nào?
View attachment 259972

Dạ anh HieuCD cho em code như ý rồi ạ. Em cám ơn anh

HieuCD đã viết:

Kết quả code khác tí

Mã:

Sub XYZ()
  Dim sArr(), Res()
  Dim sRow&, i&, thu&, thu2&, chi&, chi2&, ngay$, phieu$
 
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("H2") = 1
    .Range("H2:H" & i).DataSeries
    .Range("B2:I" & i).Sort .Range("B2"), 1, .Range("C2"), , 1, Header:=xlNo
    sArr = .Range("B1:G" & i).Value
    sRow = UBound(sArr)
    ReDim Res(2 To sRow, 1 To 1)
    For i = 2 To sRow
      If sArr(i, 2) = Empty Then
        If Mid(sArr(i, 5), 1, 3) = "111" Then
          thu = thu + 1
          Res(i, 1) = "PT" & Format(sArr(i, 1), "DDMMYY.") & thu
        ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
          chi = chi + 1
          Res(i, 1) = "PC" & Format(sArr(i, 1), "DDMMYY.") & chi
        End If
      Else
        If sArr(i, 1) <> sArr(i - 1, 1) Or sArr(i, 2) <> sArr(i - 1, 2) Then
          If Mid(sArr(i, 5), 1, 3) = "111" Then
            thu2 = thu2 + 1
            Res(i, 1) = "PTCT" & Format(sArr(i, 1), "DDMMYY.") & thu2
          ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
            chi2 = chi2 + 1
            Res(i, 1) = "PCCT" & Format(sArr(i, 1), "DDMMYY.") & chi2
          End If
        Else
          Res(i, 1) = Res(i - 1, 1)
        End If
      End If
    Next i
    .Range("A2").Resize(sRow - 1) = Res
    .Range("A2:I" & i).Sort .Range("H2"), 1, Header:=xlNo
    .Range("H2").Resize(sRow - 1) = Empty
  End With
  Application.ScreenUpdating = True
End Sub

Chạy ok lắm, em cám ơn mọi người đã giúp đỡ

kobebryant · 3/6/21

HieuCD đã viết:

Kết quả code khác tí

Mã:

Sub XYZ()
  Dim sArr(), Res()
  Dim sRow&, i&, thu&, thu2&, chi&, chi2&, ngay$, phieu$
 
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("H2") = 1
    .Range("H2:H" & i).DataSeries
    .Range("B2:I" & i).Sort .Range("B2"), 1, .Range("C2"), , 1, Header:=xlNo
    sArr = .Range("B1:G" & i).Value
    sRow = UBound(sArr)
    ReDim Res(2 To sRow, 1 To 1)
    For i = 2 To sRow
      If sArr(i, 2) = Empty Then
        If Mid(sArr(i, 5), 1, 3) = "111" Then
          thu = thu + 1
          Res(i, 1) = "PT" & Format(sArr(i, 1), "DDMMYY.") & thu
        ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
          chi = chi + 1
          Res(i, 1) = "PC" & Format(sArr(i, 1), "DDMMYY.") & chi
        End If
      Else
        If sArr(i, 1) <> sArr(i - 1, 1) Or sArr(i, 2) <> sArr(i - 1, 2) Then
          If Mid(sArr(i, 5), 1, 3) = "111" Then
            thu2 = thu2 + 1
            Res(i, 1) = "PTCT" & Format(sArr(i, 1), "DDMMYY.") & thu2
          ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
            chi2 = chi2 + 1
            Res(i, 1) = "PCCT" & Format(sArr(i, 1), "DDMMYY.") & chi2
          End If
        Else
          Res(i, 1) = Res(i - 1, 1)
        End If
      End If
    Next i
    .Range("A2").Resize(sRow - 1) = Res
    .Range("A2:I" & i).Sort .Range("H2"), 1, Header:=xlNo
    .Range("H2").Resize(sRow - 1) = Empty
  End With
  Application.ScreenUpdating = True
End Sub

Nhân tiện cho mình hỏi nếu mình muốn tìm số phiếu lớn nhất của từng loại PTCT, PT, PCCT, PC thì lấy thế nào.
Với mình có 1 lệnh in hàng loạt các tên phiếu này bằng cách dùng vòng lặp nhưng khổ cái là 1 phiếu có thể có nhiều dòng nên nó in mỗi dòng 1 phiếu, ko biết làm thế nào chỉ để nó chỉ nhận 1 lần.

ActiveSheet.PageSetup.PrintArea = "$A$1:$O$26"
Dim Cll As Range
Dim SoChungTu As Range
Set SoChungTu = Sheets("Nhaplieu").Range("A2:A10000")
For Each Cll in SoChungTu
if Left(Cll,4) = "PCHD" Then
Sheet("In").Range("M5") = Cll
ActiveWindow.SelectedSheets.PrintOut
End if
Next Cll

Maika8008 · 3/6/21

kobebryant đã viết:
Nhân tiện cho mình hỏi nếu mình muốn tìm số phiếu lớn nhất của từng loại PTCT, PT, PCCT, PC thì lấy thế nào.
Với mình có 1 lệnh in hàng loạt các tên phiếu này bằng cách dùng vòng lặp nhưng khổ cái là 1 phiếu có thể có nhiều dòng nên nó in mỗi dòng 1 phiếu, ko biết làm thế nào chỉ để nó chỉ nhận 1 lần.

ActiveSheet.PageSetup.PrintArea = "$A$1:$O$26"
Dim Cll As Range
Dim SoChungTu As Range
Set SoChungTu = Sheets("Nhaplieu").Range("A2:A10000")
For Each Cll in SoChungTu
if Left(Cll,4) = "PCHD" Then
Sheet("In").Range("M5") = Cll
ActiveWindow.SelectedSheets.PrintOut
End if
Next Cll

Phải dùng 1 vòng lặp nữa bên trong để lấy hết các dòng phiếu có cùng số.
Có 2 cách:
1. Để nguyên lộn xộn như bạn thì phải duyệt từ Cll xuống đến hết dữ liệu, thấy có cùng số thì lấy thông tin
2. Sắp xếp trước rồi duyệt từ Cll đến khi khác Cll thì ngừng

Tất nhiên 2 nhanh hơn 1 nhiều.

HieuCD · 3/6/21

kobebryant đã viết:
Nhân tiện cho mình hỏi nếu mình muốn tìm số phiếu lớn nhất của từng loại PTCT, PT, PCCT, PC thì lấy thế nào.
Với mình có 1 lệnh in hàng loạt các tên phiếu này bằng cách dùng vòng lặp nhưng khổ cái là 1 phiếu có thể có nhiều dòng nên nó in mỗi dòng 1 phiếu, ko biết làm thế nào chỉ để nó chỉ nhận 1 lần.

ActiveSheet.PageSetup.PrintArea = "$A$1:$O$26"
Dim Cll As Range
Dim SoChungTu As Range
Set SoChungTu = Sheets("Nhaplieu").Range("A2:A10000")
For Each Cll in SoChungTu
if Left(Cll,4) = "PCHD" Then
Sheet("In").Range("M5") = Cll
ActiveWindow.SelectedSheets.PrintOut
End if
Next Cll

mPT, mPTCT, mPC, mPCCT là số phiếu lớn nhất của từng loại PT, PTCT, PC, PCCT

Mã:

Sub XYZ()
  Dim sArr(), Res()
  Dim sRow&, i&, thu&, thu2&, chi&, chi2&, ngay$, phieu$
  Dim mPT$, mPTCT$, mPC$, mPCCT$
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("H2") = 1
    .Range("H2:H" & i).DataSeries
    .Range("B2:I" & i).Sort .Range("B2"), 1, .Range("C2"), , 1, Header:=xlNo
    sArr = .Range("B1:G" & i).Value
    sRow = UBound(sArr)
    ReDim Res(2 To sRow, 1 To 1)
    For i = 2 To sRow
      If sArr(i, 2) = Empty Then
        If Mid(sArr(i, 5), 1, 3) = "111" Then
          thu = thu + 1
          Res(i, 1) = "PT" & Format(sArr(i, 1), "DDMMYY.") & thu
          mPT = Res(i, 1)
        ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
          chi = chi + 1
          Res(i, 1) = "PC" & Format(sArr(i, 1), "DDMMYY.") & chi
          mPC = Res(i, 1)
        End If
      Else
        If sArr(i, 1) <> sArr(i - 1, 1) Or sArr(i, 2) <> sArr(i - 1, 2) Then
          If Mid(sArr(i, 5), 1, 3) = "111" Then
            thu2 = thu2 + 1
            Res(i, 1) = "PTCT" & Format(sArr(i, 1), "DDMMYY.") & thu2
            mPTCT = Res(i, 1)
          ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
            chi2 = chi2 + 1
            Res(i, 1) = "PCCT" & Format(sArr(i, 1), "DDMMYY.") & chi2
            mPCCT = Res(i, 1)
          End If
        Else
          Res(i, 1) = Res(i - 1, 1)
        End If
      End If
    Next i
    .Range("A2").Resize(sRow - 1) = Res
    .Range("A2:I" & i).Sort .Range("H2"), 1, Header:=xlNo
    .Range("H2").Resize(sRow - 1) = Empty
  End With
  Application.ScreenUpdating = True
End Sub

Code in

Mã:

Dim Cll As Range, SoChungTu As Range, dic As Object
ActiveSheet.PageSetup.PrintArea = "$A$1:$O$26"
Set dic = CreateObject("scripting.dictionary")
Set SoChungTu = Sheets("Nhaplieu").Range("A2:A10000")
For Each Cll In SoChungTu
  If Left(Cll.Value, 4) = "PTCT" Then
    If dic.exists(Cll.Value) = False Then
      dic.Add Cll.Value, ""
      Sheet("In").Range("M5") = Cll.Value
      ActiveWindow.SelectedSheets.PrintOut
    End If
  End If
Next Cll

kobebryant · 4/6/21

HieuCD đã viết:

mPT, mPTCT, mPC, mPCCT là số phiếu lớn nhất của từng loại PT, PTCT, PC, PCCT

Mã:

Sub XYZ()
  Dim sArr(), Res()
  Dim sRow&, i&, thu&, thu2&, chi&, chi2&, ngay$, phieu$
  Dim mPT$, mPTCT$, mPC$, mPCCT$
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("H2") = 1
    .Range("H2:H" & i).DataSeries
    .Range("B2:I" & i).Sort .Range("B2"), 1, .Range("C2"), , 1, Header:=xlNo
    sArr = .Range("B1:G" & i).Value
    sRow = UBound(sArr)
    ReDim Res(2 To sRow, 1 To 1)
    For i = 2 To sRow
      If sArr(i, 2) = Empty Then
        If Mid(sArr(i, 5), 1, 3) = "111" Then
          thu = thu + 1
          Res(i, 1) = "PT" & Format(sArr(i, 1), "DDMMYY.") & thu
          mPT = Res(i, 1)
        ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
          chi = chi + 1
          Res(i, 1) = "PC" & Format(sArr(i, 1), "DDMMYY.") & chi
          mPC = Res(i, 1)
        End If
      Else
        If sArr(i, 1) <> sArr(i - 1, 1) Or sArr(i, 2) <> sArr(i - 1, 2) Then
          If Mid(sArr(i, 5), 1, 3) = "111" Then
            thu2 = thu2 + 1
            Res(i, 1) = "PTCT" & Format(sArr(i, 1), "DDMMYY.") & thu2
            mPTCT = Res(i, 1)
          ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
            chi2 = chi2 + 1
            Res(i, 1) = "PCCT" & Format(sArr(i, 1), "DDMMYY.") & chi2
            mPCCT = Res(i, 1)
          End If
        Else
          Res(i, 1) = Res(i - 1, 1)
        End If
      End If
    Next i
    .Range("A2").Resize(sRow - 1) = Res
    .Range("A2:I" & i).Sort .Range("H2"), 1, Header:=xlNo
    .Range("H2").Resize(sRow - 1) = Empty
  End With
  Application.ScreenUpdating = True
End Sub

Code in

Mã:

Dim Cll As Range, SoChungTu As Range, dic As Object
ActiveSheet.PageSetup.PrintArea = "$A$1:$O$26"
Set dic = CreateObject("scripting.dictionary")
Set SoChungTu = Sheets("Nhaplieu").Range("A2:A10000")
For Each Cll In SoChungTu
  If Left(Cll.Value, 4) = "PTCT" Then
    If dic.exists(Cll.Value) = False Then
      dic.Add Cll.Value, ""
      Sheet("In").Range("M5") = Cll.Value
      ActiveWindow.SelectedSheets.PrintOut
    End If
  End If
Next Cll

cám ơn anh, anh nhiệt tình quá.
Chúc anh 1 ngày thật vui vẻ

Đánh số thứ tự nhiều điều kiện

kobebryant

Thành viên thường trực

File đính kèm

Nhattanktnn

Thành viên gắn bó

HieuCD

Chuyên gia GPE

kobebryant

Thành viên thường trực

Nhattanktnn

Thành viên gắn bó

kobebryant

Thành viên thường trực

kobebryant

Thành viên thường trực

Maika8008

Thành viên gạo cội

HieuCD

Chuyên gia GPE

kobebryant

Thành viên thường trực

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

Facebook

Group

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