Đánh số thứ tự bằng VBA

[thao nguyen01]

Kính gửi anh/chị trên diễn đàn,

Em muốn đánh số thứ tự như mô tả trong file ạ. Em có viết code nhưng em chưa thể trộn ô các ô giống nhau lại được. Vì công việc em sếp bắt buộc theo dõi như vậy để dễ nhìn ạ. Anh/chị xem giúp em ạ. Code của em mới chỉ xử lý được một phần. Em cảm ơn nhiều ạ.

Sub chuyen()
Dim i As Long
Dim k As Long
Dim dcuoi As Long
Dim arr_N()
Dim arr_D()

dcuoi = Sheet1.Range("B10000").End(xlUp).Row
arr_N = Sheet1.Range("B4:G" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 1)

For i = 1 To UBound(arr_N, 1) Step 7
    k = k + 1
    arr_D(i, 1) = k
Next
Sheet1.Range("A10:A10000").Clear
Sheet1.Range("A10").Resize(UBound(arr_N, 1), 1) = arr_D

End Sub

 

[giaiphap]

Kính gửi anh/chị trên diễn đàn,

Em muốn đánh số thứ tự như mô tả trong file ạ. Em có viết code nhưng em chưa thể trộn ô các ô giống nhau lại được. Vì công việc em sếp bắt buộc theo dõi như vậy để dễ nhìn ạ. Anh/chị xem giúp em ạ. Code của em mới chỉ xử lý được một phần. Em cảm ơn nhiều ạ.

Sub chuyen()
Dim i As Long
Dim k As Long
Dim dcuoi As Long
Dim arr_N()
Dim arr_D()

dcuoi = Sheet1.Range("B10000").End(xlUp).Row
arr_N = Sheet1.Range("B4:G" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 1)

For i = 1 To UBound(arr_N, 1) Step 7
    k = k + 1
    arr_D(i, 1) = k
Next
Sheet1.Range("A10:A10000").Clear
Sheet1.Range("A10").Resize(UBound(arr_N, 1), 1) = arr_D

End Sub

Sửa code lại thế này xem sao.

Sub chuyen()
Dim i As Long
Dim k As Long
Dim dcuoi As Long

dcuoi = Sheet1.Range("B10000").End(xlUp).Row

For i = 1 To dcuoi Step 7
    k = k + 1
    With Sheet1.Range("A" & (i + 3)).Resize(7)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = False
        .Merge
    End With
    Sheet1.Range("A" & (i + 3)) = k
Next
Sheet1.Range("A4:A" & (dcuoi + 6)).Borders.LineStyle = 1
End Sub

 

[thao nguyen01]

Dạ, kết quả ra đúng ạ. Em cảm ơn anh nhiều.

 

[ptm0412]

Đọc thật kỹ nhé, tôi sửa code trong phạm vi bạn có thể hiểu

Sub chuyen()
Dim i As Long
Dim k As Long
Dim dcuoi As Long
Dim arr_N()
Dim arr_D()
With Sheet1
    dcuoi = .Range("F10000").End(xlUp).Row
    arr_N = .Range("F4:F" & dcuoi)
    ReDim arr_D(1 To UBound(arr_N, 1), 1 To 1)
    For i = 1 To UBound(arr_N, 1) Step 7
        k = k + 1
        arr_D(i, 1) = k
    Next
    .Range("A4:A10000").Clear
    .Range("A4").Resize(UBound(arr_N, 1), 1) = arr_D
    .Range("D4:D" & dcuoi).Copy
    .[A4].PasteSpecial Paste:=xlPasteFormats
End With
End Sub

 

[thao nguyen01]

Đọc thật kỹ nhé, tôi sửa code trong phạm vi bạn có thể hiểu

Sub chuyen()
Dim i As Long
Dim k As Long
Dim dcuoi As Long
Dim arr_N()
Dim arr_D()
With Sheet1
    dcuoi = .Range("F10000").End(xlUp).Row
    arr_N = S.Range("F4:F" & dcuoi)
    ReDim arr_D(1 To UBound(arr_N, 1), 1 To 1)
    For i = 1 To UBound(arr_N, 1) Step 7
        k = k + 1
        arr_D(i, 1) = k
    Next
    .Range("A4:A10000").ClearContents
    .Range("A4").Resize(UBound(arr_N, 1), 1) = arr_D
    .Range("D4:D" & dcuoi).Copy
    .[A4].PasteSpecial Paste:=xlPasteFormats
End With
End Sub

Dạ, em hiểu ạ. Em cảm ơn Thầy nhiều.