I think that this works--it actually creates a new worksheet.

Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Set CurWks = Worksheets("sheet1")
Set NewWks = Worksheets.Add

NewWks.Range("a1").Resize(1, 2).Value _
= Array("CATS", "Product Code")
oRow = 2

With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

For iRow = FirstRow To LastRow
For iCol = FirstCol To LastCol
If IsNumeric(.Cells(iRow, iCol).Value) Then
If .Cells(iRow, iCol).Value 0 Then
NewWks.Cells(oRow, "A").Value = .Cells(iRow, "A").Value
NewWks.Cells(oRow, "B").Value = .Cells(iRow, iCol).Value
oRow = oRow + 1
End If
End If
Next iCol
Next iRow
End With

End Sub


TimkenSteve wrote:

Hi all,
I am a VBA newbie trying to finish a macro where in columns N:AN I have
a series of cells with zeros and values

The Heading for each column is a series of values
1, 9, 10, 22, 33, 98....
the cells in each columns are populated with either THAT number or a
zero
1 9 10 22 33 98
0 0 10 0 0 98
0 9 0 22 0 98
1 0 0 0 0 0

What I want excel to do is were there is a non zero value to insert a
ROW beneath that value.
This sheet is a dump from an oracle table and in A1 there is a CATS
number (ex. 2104). I need to get the current format
CATS 1 9 22 33 98
2104 0 9 0 0 98
To
CATS Product Code
2104 9
2104 98
If I can get a row beneath each non zero cell value I can copy each
down ordinally into One column labeled Product Code and delete the
rest.

Can this be done??
Any assistance is much appreciated
Steve

--

Dave Peterson