Macro to copy and separate text

[saitken]

Hello

I have a spreadsheet like the below

Name	Date 1	Date 2	Date 3
X	20/04/2013	21/04/2013	22/04/2013
Y	21/05/2013	22/05/2013	23/05/2013
Z	22/06/2013	23/06/2013	24/06/2013

<tbody>
</tbody><colgroup><col><col span="3"></colgroup>

I would like a macro to copy and separate the 3 dates on each row to end up like the below

Name	Date 1	Date 2	Date 3
X	20/04/2013
X		21/04/2013
X			22/04/2013
Y	21/05/2013
Y		22/04/2013
Y			23/04/2013
Z	22/06/2013
Z		23/04/2013
Z			24/04/2013

<tbody>
</tbody><colgroup><col><col span="3"></colgroup>

The actual spreadsheet is much longer so to do this manually will take a long time!

Any help would be appreciated.

Thanks
Stewart

 

[Greasy]

Try this code on a sample workbook. It will work as long as there are only and always 3 dates. If you have more dates it can be modified to work that way as well.

Sub MovinAround()


Dim ws As Worksheet
Dim x As Integer


x = 2


Set ws = Sheets("Sheet1")


Do


ws.Range("A" & x).Offset(1, 0).Insert Shift:=xlDown
ws.Range("A" & x).Offset(1, 0).Insert Shift:=xlDown
ws.Range("A" & x).Offset(0, 2).Insert Shift:=xlDown
ws.Range("A" & x).Offset(0, 3).Insert Shift:=xlDown
ws.Range("A" & x).Offset(0, 3).Insert Shift:=xlDown
ws.Range("A" & x).Offset(1, 1).Insert Shift:=xlDown
ws.Range("A" & x).Offset(1, 1).Insert Shift:=xlDown
ws.Range("A" & x).Offset(2, 2).Insert Shift:=xlDown


ws.Range("A" & x).Offset(1, 0).Value = ws.Range("A" & x)
ws.Range("A" & x).Offset(2, 0).Value = ws.Range("A" & x)


x = x + 3


Loop Until ws.Range("A" & x).Value = ""


End Sub

Hope this helps, let me know if it works.

 

[Peter_SSs]

This should do a similar job for any number of date columns.
I've shown a 'Before' & 'After' screen shot where there is 4 columns of dates.
I have assumed that the data is not the result of formulas that need to be retained.

Excel Workbook
	A	B	C	D	E
1	Name	Date 1	Date 2	Date 3	Date 4
2	X	20/04/13	21/04/13	22/04/13	23/04/13
3	Y	21/05/13	22/05/13	23/05/13	24/05/13
4	Z	22/06/13	23/06/13	24/06/13	25/06/13
Data (Before)

Excel Workbook
	A	B	C	D	E
1	Name	Date 1	Date 2	Date 3	Date 4
2	X	20/04/13
3	X		21/04/13
4	X			22/04/13
5	X				23/04/13
6	Y	21/05/13
7	Y		22/05/13
8	Y			23/05/13
9	Y				24/05/13
10	Z	22/06/13
11	Z		23/06/13
12	Z			24/06/13
13	Z				25/06/13
Data (After)

Sub Rearrange()
  Dim a, b
  Dim i As Long, j As Long, r As Long
  Dim currrows As Long, currcols As Long, newrows As Long
  
  With Range("A1").CurrentRegion
    a = .Value
    currrows = UBound(a, 1) - 1
    currcols = UBound(a, 2) - 1
    newrows = currrows * currcols
    ReDim b(1 To newrows, 1 To currcols + 1)
    For i = 1 To currrows
      For j = 1 To currcols
        r = (i - 1) * currcols + j
        b(r, 1) = a(i + 1, 1)
        b(r, j + 1) = a(i + 1, j + 1)
      Next j
    Next i
    .Offset(1).Resize(newrows).Value = b
  End With
End Sub

 

[Greasy]

I knew there had to be a cleaner way of doing it, but I couldn't figure it out. If you don't mind, can you explain how "UBound" works?

 

[Peter_SSs]

I knew there had to be a cleaner way of doing it, but I couldn't figure it out. If you don't mind, can you explain how "UBound" works?

The built-in vba Help has a reasonable explanation and examples:

UBound Function

This page is specific to the Visual Basic for Applications (VBA) Language Reference for Office 2010.
Returns a Long containing the largest available subscript for the indicated dimension of an array.

Syntax

UBound(arrayname[, dimension])

The UBound function syntax has these parts:

Part ............. Description


arrayname ... Required. Name of the array variable; follows standard variable naming conventions.


dimension .... Optional; Variant (Long). Whole number indicating which dimension's upper bound is returned. Use 1 for the first dimension, 2 for the second, and so on. If dimension is omitted, 1 is assumed.


Remarks

The UBound function is used with the LBound function to determine the size of an array. Use the LBound function to find the lower limit of an array dimension.


Example

This example uses the UBound function to determine the largest available subscript for the indicated dimension of an array.

Dim Upper
Dim MyArray(1 To 10, 5 To 15, 10 To 20) ' Declare array variables.
Dim AnyArray(10)
Upper = UBound(MyArray, 1) ' Returns 10.
Upper = UBound(MyArray, 3) ' Returns 20.
Upper = UBound(AnyArray) ' Returns 10.

 

[saitken]

Hello, both macros work perfectly! Thanks. The one from Peter is ideal as I have a number of date columns and it seems to handle them whatever number. Thanks again. Stewart