Code để tự động thêm dòng

[tungtien]

Tôi có worksheet, cột A gồm các dòng có giá trị khác nhau, code nào để tự động thêm các blank rows theo giá trị của cột A. Ví dụ row 3 có giá trị 0 thì không thêm dòng nào, row 4 có giá trị 2 thì thêm 2 dòng trống lên trên dòng có giá trị 2 đó, row 5 có giá trị 4 thì thêm 4 dòng ở trên row có giá trị 4 đó.

Thanks

 

[SA_DQ]

Mình nhặt được cái này trên đường & gia công xíu để biếu bạn đây:

Option Explicit
Sub AddRowForValue()
    Dim lRow   As Long, jW  As Long
    Dim Nums As Long
    Sheet3.Select
    lRow = [a65536].End(xlUp).Row + 1
    Do
        If lRow = 1 Then Exit Do
        With Range("A" & lRow)
            Nums = .Value
            If Nums > 0 Then
                 Rows(lRow & ":" & lRow + Nums - 1).Insert Shift:=xlDown
            End If
        End With
        lRow = lRow - 1
    Loop
End Sub

 

[TrungChinhs]

Nếu Bạn bớt chút thời gian "gia công" tiếp để dán công thức từ dòng trên vào các dòng trống vừa chèn thêm thì có thể ứng dụng được vào nhiều việc?

 

[SA_DQ]

Hôm qua thấy bài của ai đó yêu cầu (!?) 1 lần nữa, nên thử thôi!

Nếu Bạn bớt chút thời gian "gia công" tiếp để dán công thức từ dòng trên vào các dòng trống vừa chèn thêm thì có thể ứng dụng được vào nhiều việc?

Đoạn code này sẽ chèn không phải lên trên, mà xuống dưới dòng, mà ô A(i) của dòng có chứa số (để tăng số dòng);
Sau đó sẽ AutoFill xuống các giá trị hay công thức

Option Explicit
Const SoCot As Byte = 9
Sub AddRowForValue()
    Dim lRow   As Long, jW  As Long, Nums As Long
    Dim Rng As Range
    
    Sheet4.Select:              lRow = [a65536].End(xlUp).Row + 1
    Do
        If lRow = 1 Then Exit Do
        With Range("A" & lRow)
            Nums = .Value
            If Nums > 0 Then
                Rows((1 + lRow) & ":" & lRow + Nums).Insert Shift:=xlDown
                Set Rng = Range(Cells(lRow, 1), Cells(lRow + Nums, SoCot))
                Range("A" & lRow).Resize(1, SoCot).Select
                Selection.AutoFill Destination:=Rng, Type:=xlFillDefault
            End If
        End With
        lRow = lRow - 1
    Loop
Exit Sub
End Sub