Insert Row

[Peco73267326]

Hi,

I need help.
in column "B" I have a list of some tools and I need to insert an empty row. Example "B2:B5" I have tool 1001 and then I need to insert a blank row.
Every week I have a different number of lines

 

[davesexcel]

Try this

Sub Rows_Insert()
    Dim sh As Worksheet
    Dim LstRw As Long, x

    Set sh = ActiveSheet
    With sh
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row

        For x = LstRw To 3 Step -1
            If .Cells(x, 1) <> .Cells(x - 1, 1) Then
                .Cells(x, 1).EntireRow.Insert
            End If
        Next
    End With
    
End Sub

 

[mohadin]

Hi
What about

Sub test()
    Dim x&, i&
    x = Cells(Rows.Count, 2).End(xlUp).Row
    Cells(2, 10000).Resize(x).Formula = "=($B2 =$B1)*1"
    For i = x To 3 Step -1
        If Cells(i, 10000) = 0 Then Cells(i, 10).EntireRow.Insert
    Next
    Columns(10000).ClearContents
End Sub

 

[davesexcel]

Ah, good point, My code should have used Column B, not Column A

       Sub Rows_Insert()
Dim sh As Worksheet
Dim LstRw As Long, x

Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row

For x = LstRw To 3 Step -1
If .Cells(x, 2) <> .Cells(x - 1, 2) Then
.Cells(x, 2).EntireRow.Insert
End If
Next
End With
   
End Sub

 

[Peco73267326]

Sub test() Dim x&, i& x = Cells(Rows.Count, 2).End(xlUp).Row Cells(2, 10000).Resize(x).Formula = "=($B2 =$B1)*1" For i = x To 3 Step -1 If Cells(i, 10000) = 0 Then Cells(i, 10).EntireRow.Insert Next Columns(10000).ClearContents End Sub

it is running :D I am Happy a thank you veryyyyyyyyyyy much.

 

[mohadin]

it is running :D I am Happy a thank you veryyyyyyyyyyy much.

You are very welcome
Thank you for the feed back
Be happy and safe
Let me provide another version
could be faster

Sub test()
    Dim x&, i&
    Dim r As Range
    x = Cells(Rows.Count, 2).End(xlUp).Row
    Cells(2, 10000).Resize(x).Formula = "=($B2 =$B1)*1"
    For i = x To 3 Step -1
        If Cells(i, 10000) = 0 Then
            If r Is Nothing Then
                Set r = Cells(i, 1)
            Else
                Set r = Union(r, Cells(i, 1))
            End If: End If
    Next
    r.EntireRow.Insert
    Columns(10000).ClearContents
End Sub

 

[davesexcel]

My code does what you wanted without using a helper column.