Giúp em code chèn dòng trống có điều kiện! (1 người xem)

[Hong.Van]

Em chào thầy cô & Anh chị!
Xin giúp em code chèn dòng trống có điều kiện, Em có diễn giải trong File đính kèm.
Em cảm ơn!

 

[ThuNghi]

Em chào thầy cô & Anh chị!
Xin giúp em code chèn dòng trống có điều kiện, Em có diễn giải trong File đính kèm.
Em cảm ơn!

Vấn đề file có công thức?
Nếu chèn dòng theo dạng Array thì nhanh nhưng sẽ ghi lại giá trị.

 

[Hong.Van]

Vấn đề file có công thức?
Nếu chèn dòng theo dạng Array thì nhanh nhưng sẽ ghi lại giá trị.

File của em không có công thức mà sử dụng code.
Em cảm ơn!

 

[ThuNghi]

File của em không có công thức mà sử dụng code.
Em cảm ơn!

Xem thử code sau

Sub ChenDong()
Dim endR&, i&, s&, k&, sodong&, nR&
Dim Arr(), ArrKQ()
With Sheets("TH")
  endR = .Cells(5000, "B").End(3).Row
  Arr = .Range("A9:B" & endR).Value
End With
ReDim ArrKQ(1 To 5000, 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr)
  If Not IsNumeric(Arr(i, 1)) Then
    s = s + 1
    For k = 1 To UBound(Arr, 2)
      ArrKQ(s, k) = Arr(i, k)
    Next k
  Else
    sodong = Arr(i, 1)
    For nR = 1 To sodong
      s = s + 1
      ArrKQ(s, 1) = sodong
    Next nR
  End If
Next i
With Sheets("TH")
  .[A9].Resize(s, UBound(Arr, 2)) = ArrKQ
End With
Erase Arr(), ArrKQ()
End Sub

 

[hoangvuluan]

Dùng thử macro sau, với những lưu ý đã ghi trong code:

Sub insRows()
Dim r As Range, iR As Long, iC As Long, i As Long, c
With Application
.ScreenUpdating = False
.EnableEvents = False
    Set r = ActiveSheet.Range("A9") ' thay doi phu hop thuc te'
    ' neu du lieu khong lien tuc (co cac dong trong o giua) '
    ' thi dat lai r cho phu hop '
    Set r = r.CurrentRegion
    iR = r.Rows.Count
    iC = r.Columns.Count
    MsgBox iR
    i = 0
    Do While i <= r.Rows.Count
        c = r(i, 1)
        If c <> "" And IsNumeric(c) And c > 0 Then
            r.Offset(i).Resize(c, iC).Rows.Insert (xlShiftDown)
            i = i + c
        End If
        i = i + 1
    Loop
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub