Hi
Try this:
Sub Move_Lists()
Dim NewRow As Long, NewColumn As Long
Dim X As Long
NewRow = 1
NewColumn = 16
If Cells(NewRow, NewColumn).Value <> "" Then
NewColumn = Cells(1, Columns.Count).End(xlToLeft).Offset(0,
1).colunm
End If
For Col = 1 To 9
For X = 2 To 31
If Cells(X, Col) <> "" Then
Cells(NewRow, NewColumn).Value = Cells(X, Col).Value
NewRow = NewRow + 1
End If
Next
Next
End Sub
Regards.
Per