Insert alternate blank rows filled a certain colour from A3:G6211

[Ironman]

Hi

I have a sheet containing data from A2 to G6210.

I need to insert a blank, shaded row between every row up to and including Col G (all of which contain data, which must not be amended).

Specifically, I would be very grateful for a module that I can run that will insert blank rows every other row, starting A3:A6211 inclusive, with the cells filled #EEE7D7 up to and including Col G.

i.e.

A3:G3 filled #EEE7D7

A5:G5 filled #EEE7D7

A7:G7 filled #EEE7D7

etc. etc.

A6211:G6211 filled #EEE7D7

Many thanks!

 

[johnnyL]

Do you know what the 'immediate window' is in the VB editor window?

 

[Ironman]

I've used it when following an instruction here a while ago, but I don't know what it actually does.

 

[johnnyL]

Ok, in the window that you paste macro codes (Shortcut = Alt+F11), Press Ctrl+G ... that should open another window titled 'Immediate window'.
In that window you can see results that would normally be displayed to a msgbox window if the code replaces msgbox with Debug.Print.

Let me know when you see the 'Immediate window' in the VB editor window ... Alt+F11 shortcut.

 

[johnnyL]

When you get to the point where you have that 'Immediate window' displayed, try this macro code in replacement of my previous code that I posted here. It should run faster as well as give you a total run time in that 'immediate window' if you go back to that screen of the VB editor ... Alt+F11 shortcut afterwards.

Sub InsertBlankShadedRowsV2a()
'
    Dim startTime                   As Single
    startTime = Timer                                                                           '   Start the stopwatch
'
    Application.ScreenUpdating = False                                                          '   Turn ScreenUpdating off
     Application.DisplayAlerts = False                                                          '   Turn DisplayAlerts off
'
    Dim i               As Long
    Dim LastRowInSheet  As Long
'
    LastRowInSheet = Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
'
    Range("A2:A" & LastRowInSheet).Select
'
    For i = 1 To Range("A2:A" & LastRowInSheet).EntireRow.Count
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Resize(1, 7).Offset(1, 0).Interior.Color = RGB(229, 222, 207)
        ActiveCell.Offset(2, 0).Select
    Next
'
     Application.DisplayAlerts = True                                                           ' Turn DisplayAlerts back on
    Application.ScreenUpdating = True                                                           ' Turn ScreenUpdating back on
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                         ' Display Total run time (Ctrl-G)
'
MsgBox "Completed!"                                                                             ' Let user know that the process is complete
End Sub

This version of code that previously took my computer about 1 minute to run, now completes in about 13 seconds.

 

[Ironman]

OK, opened the Immediate window, just running your amended code now...

 

[Ironman]

Hmm it's still running but because it's identical to the previous macro, I can't see the progress. All I know is it's taking even longer than the initial code.

 

[johnnyL]

Hmm it's still running but because it's identical to the previous macro, I can't see the progress. All I know is it's taking even longer than the initial code.

Code from Post #6 is not the same as code from Post # 14.

 

[Peter_SSs]

Took about 1 minute to run on my computer for 6210 original rows of data.

For same size data (no formulas, event code etc) this one took 0.6 seconds for me so you could give it a go too.

I assumed that column A can be used to determine last row of data and that column H could be used as a helper column.

Sub Insert_Rows()
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
  End With
  With Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row)
      .Value = Evaluate("row(" & .Address & ")")
      .Offset(.Rows.Count).Value = .Value
      .Resize(.Rows.Count * 2).EntireRow.Resize(, 8).Sort Key1:=Columns(8), Order1:=xlAscending, Header:=xlNo
      With .Resize(.Rows.Count * 2)
        .Value = Evaluate("1/mod(row(" & .Address & "),2)")
        Intersect(.SpecialCells(xlConstants, xlNumbers).EntireRow, Columns("A:G")).Interior.Color = RGB(229, 222, 207)
        .ClearContents
      End With
  End With
  With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
  End With
End Sub

 

[johnnyL]

Going off of @Peter_SSs idea:

Sub InsertBlankShadedRowsV3()
'
    Dim startTime           As Single
    startTime = Timer                                                                                           ' Start the stopwatch
'
    Dim LastRowInSheet      As Long
    Dim LastColumnInSheet   As String
'
    LastRowInSheet = Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row                                  ' Save LastRowInSheet
    LastColumnNumberInSheet = Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column                   ' Returns a Column Number
'
    Application.ScreenUpdating = False                                                                          ' Turn ScreenUpdating off
       Application.Calculation = xlCalculationManual                                                            ' Turn Calculation off
      Application.EnableEvents = False                                                                          ' Turn EnableEvents off
'
    With Range(Cells(2, LastColumnNumberInSheet + 1), Cells(LastRowInSheet, LastColumnNumberInSheet + 1))       ' Create Helper column
        .Value = Evaluate("row(" & .Address & ")")                                                              ' Load Helper values
        .Offset(.Rows.Count).Value = .Value
        .Resize(.Rows.Count * 2).EntireRow.Resize(, 8).Sort Key1:=Columns(8), Order1:=xlAscending, Header:=xlNo ' Insert Blank rows
'
        With .Resize(.Rows.Count * 2)
            .Value = Evaluate("1/mod(row(" & .Address & "),2)")
            .ClearContents                                                                                      ' Clear Helper Column
        End With
'
        For i = 1 To Range("A2:A" & LastRowInSheet).EntireRow.Count
            ActiveCell.Resize(1, 7).Offset(1, -1).Interior.Color = RGB(229, 222, 207)                           ' Shade Blank row
            ActiveCell.Offset(2, 0).Select
        Next
    End With
'
      Application.EnableEvents = True
       Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                         ' Display Total run time (Ctrl-G)
'
MsgBox "Completed!"                                                                             ' Let user know that the process is complete
End Sub

 

[Ironman]

@johnnyL understood - used code from Post #14 - "Time to complete = 1970.838 seconds."

@Peter_SSs Hi Peter, now running your code, many thanks

@johnnyL I'll then try yours.