Đánh số thứ tự theo ngày bằng VBA (1 người xem)

[PAT_KC]

Chào mọi người.
Mình có 1 file (đính kèm) muốn xin code để sau mỗi 1 ngày số thứ tự lại được đánh lại từ 1.
Xin cảm ơn

 

[snow25]

Chào mọi người.
Mình có 1 file (đính kèm) muốn xin code để sau mỗi 1 ngày số thứ tự lại được đánh lại từ 1.
Xin cảm ơn

Thử cái này.Nếu dữ liệu không sắp xếp thì phải chơi code khác

Sub danhso()
    Dim i As Long, lr As Long, dk As Long, arr, kq, dem As Integer
    lr = Range("C" & Rows.Count).End(xlUp).Row
    arr = Range("B5:C" & lr).Value
    ReDim kq(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If dk <> CLng(arr(i, 2)) Then
           dem = 0
        End If
        dk = CLng(arr(i, 2))
        dem = dem + 1
        kq(i, 1) = dem
    Next i
        Range("A5:A" & lr).Value = kq
End Sub

 

[HieuCD]

Thử cái này.Nếu dữ liệu không sắp xếp thì phải chơi code khác

Sub danhso()
    Dim i As Long, lr As Long, dk As Long, arr, kq, dem As Integer
    lr = Range("C" & Rows.Count).End(xlUp).Row
    arr = Range("B5:C" & lr).Value
    ReDim kq(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If dk <> CLng(arr(i, 2)) Then
           dem = 0
        End If
        dk = CLng(arr(i, 2))
        dem = dem + 1
        kq(i, 1) = dem
    Next i
        Range("A5:A" & lr).Value = kq
End Sub

Theo logic thì lệnh "dk = CLng(arr(i, 2))" nằm lạc vị trí

 

[phulien1902]

Theo logic thì lệnh "dk = CLng(arr(i, 2))" nằm lạc vị trí

Em nghĩ Code trên hay ở chỗ "lạc vị trí" đó.

 

[HieuCD]

Em nghĩ Code trên hay ở chỗ "lạc vị trí" đó.

Do Lạc vị trí nên nhiều lần chạy dòng lệnh không cần thiết kiểu: dk=dk

 

[snow25]

Do Lạc vị trí nên nhiều lần chạy dòng lệnh không cần thiết kiểu: dk=dk

Cho nó về vị trí đây anh.

Sub danhso()
    Dim i As Long, lr As Long, dk As Long, arr, kq, dem As Integer
    lr = Range("C" & Rows.Count).End(xlUp).Row
    arr = Range("B5:C" & lr).Value
    ReDim kq(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If dk <> CLng(arr(i, 2)) Then
           dem = 0
           dk = CLng(arr(i, 2))
        End If
        dem = dem + 1
        kq(i, 1) = dem
    Next i
        Range("A5:A" & lr).Value = kq
End Sub

 

[SA_DQ]

Mình có con này, xin giới thiệu đến chủ bài đăng tham khảo lúc rỗi:

Const Alf As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Sub SoTTTheoNgay()
Dim WF As Object, Rng As Range, sRng As Range:             Dim MyAdd As String, STT As String
Dim Rws As Long, W As Integer, Dm As Byte, J As Long, fDat As Date, lDat As Date, SoNgay As Integer


Set WF = Application.WorksheetFunction
Rws = [C5].CurrentRegion.Rows.Count
Set Rng = [C4].Resize(Rws)
fDat = WF.Min(Rng.Offset(1)):                              lDat = WF.Max(Rng.Offset(1))
Rng.Offset(1).NumberFormat = "MM/DD/yyyy":                 SoNgay = lDat - fDat
ReDim Arr(1 To Rws, 1 To 3)
For J = 0 To SoNgay
    Set sRng = Rng.Find(Format(J + fDat, "MM/DD/yyyy"), , xlValues, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            W = W + 1:                                      Dm = Dm + 1
            STT = Mid(Alf, 9 + Month(J + fDat), 1)
            Arr(W, 1) = STT & Mid(Alf, 1 + Day(J + fDat), 1) & Right("00" & CStr(Dm), 3)
            Arr(W, 2) = sRng.Offset(, -1).Value:            Arr(W, 3) = sRng.Value
            Set sRng = Rng.FindNext(sRng):
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        Dm = 0
    End If
Next J
[A5].Resize(W, 3).Value = Arr()
End Sub