Macro Help for Simple function Please

[Guest]

Hello. I have a spreadsheet displaying 150 weeks across the columns and
dozens of products in my rows. The cells show sales data $ for each product.
Of the 150 weeks across the page, many of the cells contain NA or 0 data
because the products were launched at different times over the 150 weeks.
What I would like to do is simply delete the zero data cells from each row up
to the first week of sales for that product, effectively lining up all the
products so that I can view a sales launch comparison of week 1 vs week 2 etc
regardless of the dates. Can anyone please help? Thank you.

 

[Tom Ogilvy]

This assumes column A has the products listed and the sales start in column
B.

Sub ClearZerosAndErrors()
Dim cell As Range, rng As Range
Dim lastrow As Long, i As Long
With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
For i = lastrow To 2 Step -1
With ActiveSheet
Set rng = .Range(.Cells(i, 2), .Cells(i, 2).Resize(1, 150))
End With
For Each cell In rng
If Not IsError(cell) Then
If IsNumeric(cell) Then
If CDbl(cell.Value) <> 0 Then
Exit For
Else
cell.ClearContents
End If
End If

Else
cell.ClearContents
End If
Next cell
Next i
End Sub

Test this on a copy of your worksheet.

 

[Guest]

Hello Tom. Your macro clears all the zero sales cells but does not "cut the
cells from where data began and paste them starting in the 2nd column. Is
that something you can help with please? Thank you.

 

[Tom Ogilvy]

Sub ClearZerosAndErrors()
Dim cell As Range, rng As Range
Dim cell1 As Range, cell2 As Range
Dim lastrow As Long, i As Long
With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
For i = lastrow To 2 Step -1
With ActiveSheet
Set rng = .Range(.Cells(i, 2), .Cells(i, 2).Resize(1, 150))
Set cell1 = .Cells(i, 2)
End With
For Each cell In rng
Set cell2 = Nothing
If Not IsError(cell) Then
If IsNumeric(cell) Then
If CDbl(cell.Value) <> 0 Then
Set cell2 = cell.Offset(0, -1)
Exit For
End If
End If
End If
Next cell
If Not cell2 Is Nothing Then
rng.Parent.Range(cell1, cell2).Delete Shift:=xlShiftToLeft
End If
Next i
End Sub

 

[Guest]

That's perfect. Thank you so much!!

Sub ClearZerosAndErrors()
Dim cell As Range, rng As Range
Dim cell1 As Range, cell2 As Range
Dim lastrow As Long, i As Long
With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
For i = lastrow To 2 Step -1
With ActiveSheet
Set rng = .Range(.Cells(i, 2), .Cells(i, 2).Resize(1, 150))
Set cell1 = .Cells(i, 2)
End With
For Each cell In rng
Set cell2 = Nothing
If Not IsError(cell) Then
If IsNumeric(cell) Then
If CDbl(cell.Value) <> 0 Then
Set cell2 = cell.Offset(0, -1)
Exit For
End If
End If
End If
Next cell
If Not cell2 Is Nothing Then
rng.Parent.Range(cell1, cell2).Delete Shift:=xlShiftToLeft
End If
Next i
End Sub