Const DATA_WORKSHEET As String = "Sheet1"
Const OUTPUT_WORKSHEET As String = "ExtractedData"
Sub ExtractRowsWithNonZeroQnty()
Dim shData As Worksheet
Set shData = Worksheets(DATA_WORKSHEET)
Dim shOutput As Worksheet
On Error Resume Next
Set shOutput = Worksheets(OUTPUT_WORKSHEET)
If shOutput Is Nothing Then
'Add and name output worksheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = OUTPUT_WORKSHEET
Set shOutput = Worksheets(OUTPUT_WORKSHEET)
'Create header row
shOutput.Range("A1").Value = "Item"
shOutput.Range("B1").Value = "Descr"
shOutput.Range("C1").Value = "Date"
Else
'Clear output worksheet except for header
shOutput.UsedRange.Clear
shOutput.Range("A1").Value = "Item"
shOutput.Range("B1").Value = "Descr"
shOutput.Range("C1").Value = "Date"
End If
Dim db As Range
Set db = shData.UsedRange
Dim rRow As Range
Dim rcell As Range
Dim iCol As Integer
Dim iColNonZero As Integer
For Each rRow In db.Rows
If rRow.Row > 1 Then
For Each rcell In rRow.Cells
If rcell.Column >= 3 Then
If rcell.Value > 0 Then
iColNonZero = rcell.Column
Exit For
End If
End If
Next rcell
Dim targetRow As Range
Set targetRow = shOutput.Range("A" & Rows.Count).End(xlUp).Offset(1)
If iColNonZero > 0 Then
targetRow.Cells(1, 1).Value = rRow.Cells(1, 1).Value
targetRow.Cells(1, 2).Value = rRow.Cells(1, 2).Value
targetRow.Cells(1, 3).Value = db.Cells(1, iColNonZero).Value
iColNonZero = 0
Else
targetRow.Cells(1, 1).Value = rRow.Cells(1, 1).Value
targetRow.Cells(1, 2).Value = rRow.Cells(1, 2).Value
targetRow.Cells(1, 3).Value = "None"
End If
End If
Next rRow
End Sub
It could be written in a more compact fashion, but I am afraid doing so would obscure its intentions.