Macro insert lines

[Esrei]

This is my macro to insert lines if the value in b chanbes. I want it to
inset 26 lines it only inserts 1 please help

Sub Deilv()
Dim LastRow As Long
Dim row_index As Long
Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").EntireRow.insert _
(x24ShiftDown)
End If
Next
End Sub

 

[Norman Jones]

Hi Esrei,

Try:

Sub Deilv()
Dim LastRow As Long
Dim row_index As Long

Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").Resize(26).EntireRow. _
Insert Shift:=xlDown
End If
Next
Application.ScreenUpdating = True
End Sub

 

[Esrei]

Thanks it works like a charm.
Now one step more
I want to copy range B2:K25 and insert it ont the 2nd row of the 26 that was
just inserted by the first part of the macro.
Thanks

 

[Norman Jones]

Hi Esrei,

Try:

'===================>>
Public Sub Deilv2()
Dim LastRow As Long
Dim row_index As Long
Dim rng As Range

Set rng = Range("B2:K25")

Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").Resize(26).EntireRow. _
Insert Shift:=xlDown
rng.Copy Destination:=Cells(row_index + 1, "B").Offset(1)
End If
Next
Application.ScreenUpdating = True
End Sub
'<<===================

 

[Esrei]

Hi Norman

Thanks a lot

Now these invoices just need totals
In the first row after a value in B in E the word totals must be inserted,
H, I and K must be summed the amount of lines differ on each invoice but
there is a heading from where it must be summed. CTNS(H), QTY(I), Total(K)

Thanks a lot.