Sub to transform table into cols

[Max]

Source table is in sheet: V, cols A across to D ... ,
col headers in row1, data from row2 down, viz

Cust# Visit01 Visit02 Visit03 ... Visit200
Cust001 Date01 Date03
Cust002 Date01
Cust003 Date03 Date04 Date05
Cust004 <blank> 'no visits data as yet for this cust
Cust005 Date05
etc

In a new sheet,
I would like to make a simple 3 cols table (cols A to C)
from what's in V, ie:

Cust# Date Visit#
Cust001 Date01 1
Cust001 Date03 2
Cust002 Date01 1
Cust003 Date03 1
Cust003 Date04 2
Cust003 Date05 3
Cust004 <blank> <blank>
Cust005 Date05 1
etc

Appreciate your insights & help on a sub to achieve the above, guys. Thanks.

 

[Incidental]

Hi Max

The code below would be one way of doing it or should hopefully give
you an idea of one way to do what your looking for

Option Explicit
Dim MyCell, MyRng As Range
Dim LstRow, LstCol, i, Cntr As Integer

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Sheets(1).Activate 'Change to your reference sheet "V"??
LstRow = [A1].End(xlDown).Row
Set MyRng = Range("A2", "A" & LstRow)

For Each MyCell In MyRng
i = 1
Cntr = 1
MyCell.Activate
LstCol = ActiveCell.End(xlToRight).Column

Do While Cntr < LstCol
ActiveCell.Offset(0, 1).Select
ActiveCell.Copy
Sheets(2).Activate 'Change to your destination sheet
[A6596].End(xlUp).Offset(1, 0).Activate
ActiveCell = MyCell
ActiveCell.Offset(0, 1).PasteSpecial
(xlPasteValues)
ActiveCell.Offset(0, 1) = i
i = i + 1
Cntr = Cntr + 1
Sheets(1).Activate
Loop

Next MyCell

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Hope it helps

S

 

[Max]

Many thanks for your response, S! Your sub below works great except for the
situation of customers w/o any visits data as yet, eg Cust004 in the sample,
The sub will repeat Cust004 in col A for a full 255 lines and will list the
numbers 1-255 under the 3rd col (Visits#). How could the sub be tweaked a
little to yield the desired result of just: Cust004 <blank> <blank>
for any such customers w/o any visits data? Thanks.


Option Explicit

Sub Transform()
Dim MyCell, MyRng As Range
Dim LstRow, LstCol, i, Cntr As Integer

Application.ScreenUpdating = False
Sheets(1).Activate 'Change to your reference sheet "V"??
LstRow = [A1].End(xlDown).Row
Set MyRng = Range("A2", "A" & LstRow)

For Each MyCell In MyRng
i = 1
Cntr = 1
MyCell.Activate
LstCol = ActiveCell.End(xlToRight).Column

Do While Cntr < LstCol
ActiveCell.Offset(0, 1).Select
ActiveCell.Copy
Sheets(2).Activate 'Change to your destination sheet
[A6596].End(xlUp).Offset(1, 0).Activate
ActiveCell = MyCell
ActiveCell.Offset(0, 1).PasteSpecial (xlPasteValues)
ActiveCell.Offset(0, 1) = i
i = i + 1
Cntr = Cntr + 1
Sheets(1).Activate
Loop

Next MyCell

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[Incidental]

Hi Max

Sorry i didn't test it with your given example, the following code
should work it just has a small addition to fix that issue it will
just reset the counter for lstrow to 1

Option Explicit
Dim MyCell, MyRng As Range
Dim LstRow, LstCol, i, Cntr As Integer


Private Sub CommandButton1_Click()


Application.ScreenUpdating = False
Sheets(1).Activate 'Change to your reference sheet "V"??
LstRow = [A1].End(xlDown).Row
Set MyRng = Range("A2", "A" & LstRow)


For Each MyCell In MyRng
i = 1
Cntr = 1
MyCell.Activate
LstCol = ActiveCell.End(xlToRight).Column
'******** code added below *************
If LstCol = 256 Then
LstCol = 1
End If
'***************************************
Do While Cntr < LstCol
ActiveCell.Offset(0, 1).Select
ActiveCell.Copy
Sheets(2).Activate 'Change to your destination sheet
[A6596].End(xlUp).Offset(1, 0).Activate
ActiveCell = MyCell
ActiveCell.Offset(0, 1).PasteSpecial
(xlPasteValues)
ActiveCell.Offset(0, 1) = i
i = i + 1
Cntr = Cntr + 1
Sheets(1).Activate
Loop


Next MyCell


Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub


later

Steve

 

[Incidental]

Hi again

sorry max scrap the last code was done in haste the code below should
sort you out

Option Explicit
Dim MyCell, MyRng As Range
Dim LstRow, LstCol, i, Cntr As Integer


Private Sub CommandButton1_Click()


Application.ScreenUpdating = False
Sheets(1).Activate 'Change to your reference sheet "V"??
LstRow = [A1].End(xlDown).Row
Set MyRng = Range("A2", "A" & LstRow)


For Each MyCell In MyRng
i = 1
Cntr = 1
MyCell.Activate
LstCol = ActiveCell.End(xlToRight).Column
'******** code added below *************
If LstCol = 256 Then
LstCol = 1
Cntr = 0
End If
'***************************************
Do While Cntr < LstCol
ActiveCell.Offset(0, 1).Select
ActiveCell.Copy
Sheets(2).Activate 'Change to your destination sheet
[A6596].End(xlUp).Offset(1, 0).Activate
ActiveCell = MyCell
ActiveCell.Offset(0, 1).PasteSpecial
(xlPasteValues)
ActiveCell.Offset(0, 1) = i
i = i + 1
Cntr = Cntr + 1
'******** code added below *************
If ActiveCell.Value = "" Then
ActiveCell.Offset(0, 1).Value = ""
End If
'***************************************
Sheets(1).Activate
Loop


Next MyCell


Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub


take care

Steve

 

[Max]

Steve,
Many thanks! The amendments did it.
Runs well and delivers the expected results.