Insert Row if the Entire Row Cell has Zero

[unknownymous]

Hi Guys,

How can I insert a blank row if the entire row has zero ?

Before:

Name	Track1	Track2	Track3	Track4
Ben	1	1	1	2
Sam	3	4	5	6
Anna	1	0	5	9
Ted	0	0	0	0

<tbody>
</tbody>

After:

Name	Track1	Track2	Track3	Track4
Sam	3	4	5	6
Ben	1	1	1	2
Anna	1	0	5	9
ZEROES
Ted	0	0	0	0

<tbody>
</tbody>

Thanks in advance for the help.

 

[Trebor76]

Try this:

Option Explicit
Sub Macro2()
    
    Dim lngLastCol As Long
    Dim strLastCol As String
    Dim lngLastRow As Long
    Dim lngMyRow   As Long
    
    Application.ScreenUpdating = False
    
    lngLastCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    strLastCol = Left(Cells(1, lngLastCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngLastCol).Address(True, False)) - 1)
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 2 Step -1
        If Evaluate("SUM(B" & lngMyRow & ":" & strLastCol & lngMyRow & ")") = 0 Then
            Rows(lngMyRow).EntireRow.Insert
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Peter_SSs]

.. or possibly this

Sub insertRows()
  Dim a As Variant
  Dim i As Long
  Dim sTest As String
  
  Application.ScreenUpdating = False
  With Range("A1").CurrentRegion
    a = .Offset(, 1).Resize(, .Columns.Count - 1).Value
  End With
  sTest = Mid(Replace(String(UBound(a, 2), "0"), 0, "|0"), 2)
  For i = UBound(a) To 2 Step -1
    If Join(Application.Index(a, i, 0), "|") = sTest Then Rows(i).Insert
  Next i
  Application.ScreenUpdating = True
End Sub

I haven't addressed anything about the changed order of the rows shown as that wasn't asked about and we have no details about.

 

[Peter_SSs]

Try this:

Robert, a comment on your code. It may not be possible with the OP's data but it would insert a blank row above a row that contained
3, 4, -1, -6

It would also insert a blank row above a row that was already blank in those 4 columns.

In both examples above the rows don't meet the OP's stated requirement.

 

[Trebor76]

Good points. Thanks Peter

 

[Peter_SSs]

Good points. Thanks Peter

No problem.

One further tip. The red part is not required here (though it won't hurt) as Rows(lngMyRow) already is an entire row.

Rows(lngMyRow).EntireRow.Insert

 

[Trebor76]

Hi Peter,

Based on your kind advice, here's my revised code:

Option Explicit
Sub Macro2()
    
    Dim lngLastCol As Long
    Dim strLastCol As String
    Dim lngLastRow As Long
    Dim lngMyRow   As Long
    
    Application.ScreenUpdating = False
    
    lngLastCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    strLastCol = Left(Cells(1, lngLastCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngLastCol).Address(True, False)) - 1)
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 2 Step -1
        'If every column from column B to the last column are all zero, then...
        If Evaluate("COUNTIF(B" & lngMyRow & ":" & strLastCol & lngMyRow & ",0)") = lngLastCol - 1 Then
            '...insert a blank row
            Rows(lngMyRow).Insert
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

What do you think?

Thanks,

Robert

 

[unknownymous]

I forgot to mention that each Track column should be sorted in descending order. Thanks Peter for the help

 

[unknownymous]

Thanks Peter and Trebor!

 

[Rick Rothstein]

Here is another macro that should also work...

[table="width: 500"]
[tr]
	[td]Sub InsertRowsAboveAllZeroes()
  Dim R As Long, Arr As Variant
  Arr = Split(Application.Trim(Join(Application.Transpose(Evaluate("IF(COUNTIF(OFFSET(B1,ROW(A1:A26)-1,0,1," & Cells(1, Columns.Count).End(xlToLeft).Column - 1 & "),""<>0""),"""",Row(A1:A26))")))))
  Application.ScreenUpdating = False
  For R = UBound(Arr) To 0 Step -1
    If Len(Arr(R)) Then Rows(Arr(R)).Insert
  Next
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]