Този код копира всички клетки, чието съдържание е различно от 0 или празно и ги пейства едно под друго в колона А, от клетка А1 надолу. Не е най-оптималният вариант, но би трябвало да ти свърши работа:
Sub CopyDescriptionsInColumnA()
Dim c As Range
counter = 0
For Each c In Range("B1:Z50")
c.Select
If c.Value <> "0" And c.Value <> "" Then
counter = counter + 1
Cells(counter, 1).Value = c.Value
End If
Next
End Sub
Промени си рейнджа според размера на таблицата, която проверяваш. Ето референция как да подкараш макрото в ексел.