Insert dòng trắng với số lượng dòng được xác định trước trên bảng tính (1 người xem)

[Nguyễn Hồng Quang]

Xin chào cả nhà
Mình có lập 1 code với công dụng là insert dòng với số lượng dòng dự định insert được xác định trước trên bảng tính (theo fomat của mình).
(ghi chú : các dòng sau khi được insert sẽ được copy toàn bộ nội dung tính từ cột E của dòng bắt đầu insert)
Ví dụ : Muốn insert 3 dòng kể từ dòng 2 thì gõ 3 vào ô D3, muốn insert 5 dòng kể từ dòng 6 thì gõ 5 vào ô D6.
Sau khi chạy code thì mình thấy bị insert thiếu mất 1 dòng, mình loay hoay mãi mà chưa sửa được mong mọi người giúp đỡ
Dưới đây là code và file test đính kèm
Xin chân thành cảm ơn

Sub Button13_Click()lr = [a2].End(xlDown).Row
    For i = lr To 2 Step -1
        If Cells(i, 4) > 1 Then
           Cells(i + 1, 4).Select
           r = Cells(i, 4)
            Selection.Resize(Cells(i, 4) - 1, 1).Select
            Selection.EntireRow.Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(i, 4).Select
            Selection.Value = 1
            Selection.Resize(r, 1).Select
            Selection.FillDown
            Selection.Resize(r, 2).Select
            Selection.FillDown
            Selection.Resize(r, 3).Select
            Selection.FillDown
            Selection.Resize(r, 4).Select
            Selection.FillDown
            Selection.Resize(r, 5).Select
            Selection.FillDown
            Selection.Resize(r, 6).Select
            Selection.FillDown
            Selection.Resize(r, 7).Select
            Selection.FillDown
            Selection.Resize(r, 8).Select
            Selection.FillDown
            Selection.Resize(r, 9).Select
            Selection.FillDown


        End If
 lr = [a2].End(xlDown).Row
    Next
End Sub

 

[Ba Tê]

Xin chào cả nhà
Mình có lập 1 code với công dụng là insert dòng với số lượng dòng dự định insert được xác định trước trên bảng tính (theo fomat của mình).
(ghi chú : các dòng sau khi được insert sẽ được copy toàn bộ nội dung tính từ cột E của dòng bắt đầu insert)
Ví dụ : Muốn insert 3 dòng kể từ dòng 2 thì gõ 3 vào ô D3, muốn insert 5 dòng kể từ dòng 6 thì gõ 5 vào ô D6.
Sau khi chạy code thì mình thấy bị insert thiếu mất 1 dòng, mình loay hoay mãi mà chưa sửa được mong mọi người giúp đỡ
Dưới đây là code và file test đính kèm
Xin chân thành cảm ơn

Sub Button13_Click()lr = [a2].End(xlDown).Row
    For i = lr To 2 Step -1
        If Cells(i, 4) > 1 Then
           Cells(i + 1, 4).Select
           r = Cells(i, 4)
            Selection.Resize(Cells(i, 4) - 1, 1).Select
            Selection.EntireRow.Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(i, 4).Select
            Selection.Value = 1
            Selection.Resize(r, 1).Select
            Selection.FillDown
            Selection.Resize(r, 2).Select
            Selection.FillDown
            Selection.Resize(r, 3).Select
            Selection.FillDown
            Selection.Resize(r, 4).Select
            Selection.FillDown
            Selection.Resize(r, 5).Select
            Selection.FillDown
            Selection.Resize(r, 6).Select
            Selection.FillDown
            Selection.Resize(r, 7).Select
            Selection.FillDown
            Selection.Resize(r, 8).Select
            Selection.FillDown
            Selection.Resize(r, 9).Select
            Selection.FillDown


        End If
 lr = [a2].End(xlDown).Row
    Next
End Sub

Bạn đưa dữ liệu ảo quá.
Trong file bạn, nếu không có bảng dưới thì [a2].end(xldown) sẽ đi tuốt cuối bảng.
Số 1 có chèn không?
Chèn xong thì cột Số lượng nếu lớn hơn 1 chuyển thành 1?
Chèn dòng thì các cột có công thức thì sao?
Bạn chạy thử Sub này coi sao?

Public Sub S_GPE()
Dim sArr(), dArr(), I As Long, iK As Long, J As Long, K As Long, N As Long, R As Long, C As Long
sArr = Range("A1").CurrentRegion.FormulaR1C1
R = UBound(sArr)
ReDim dArr(1 To R * 10, 1 To 13)
For I = 2 To R
    N = 0
    If sArr(I, 4) <> "" Then N = sArr(I, 4) - 1
    For iK = 0 To N
        K = K + 1
        For J = 1 To 13
            dArr(K, J) = sArr(I, J)
        Next J
        If sArr(I, 4) <> "" Then dArr(K, 4) = 1
    Next iK
Next I
Range("A2").Resize(K, 13) = dArr
Range("A2").Resize(K, 13).Borders.LineStyle = 1
End Sub

 

[Nguyễn Hồng Quang]

Chân thành cảm ơn bác Ba tê