Transpose every 3 rows to 3 columns

[praveenpatel421983]

Hi,
I have a excel which has 1000 of rows but every 3 rows belongs to one category. I want to transpose into 3 columns. I searched through various data but couldn't find the right looping. Please help. Number of columns for each category is not same.

Category 1	Day 1	a	b	c	d	e	f	g	h
	Day 2	i	j	k	l	m	n	o	p
	Day 3	q	r	s	t	u	v	w	x
Category 2	Day 1	a	b	c	d	e	f
	Day 2	g	h	i	j	k	l
	Day 3	m	n	o	p	q	r
Category 3	Day 1	a	b	c	d	e	f	g
	Day 2	h	i	j	k	l	m	n
	Day 3	o	p	q	r	s	t	u
Category 4	Day 1	a	b	c	d	e
	Day 2	f	g	h	i	j
	Day 3	k	l	m	n	o

<tbody>
</tbody>

It should come like below format

	Day 1	Day 2	Day3
Category 1	a	i	q
	b	j	r
	c	k	s
	d	l	t
	e	m	u
	f	n	v
	g	o	w
	h	p	x
Category 2	a	g	m
	b	h	n
	c	i	o
	d	j	p
	e	k	q
	f	l	r
Category 3	a	h	o
	b	i	p
	c	j	q
	d	k	r
	e	l	s
	f	m	t
	g	n	u
Category 4	a	f	k
	b	g	l
	c	h	m
	d	i	n
	e	j	o

<tbody>
</tbody>

Can anyone please help?

thanks
Praveen Patelappa

 

[VBA Geek]

With your data beginning A1, try this:

Sub trnsp()
Const groupNum As Long = 3
Dim k As Long, vDays As Variant, vValues As Variant, lCol As Long

Application.ScreenUpdating = False

For k = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -groupNum
    lCol = Rows(k).Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious).Column
    
    vDays = Range("A" & k).Offset(, 1).Resize(groupNum).Value
    vValues = Range("A" & k).Offset(, 2).Resize(groupNum, lCol - 2)
    
    Range("A" & k).Offset(0, 1).Resize(groupNum, lCol - 1).ClearContents
    
    If k = 1 Then Range("A" & k).Offset(, 1).Resize(, groupNum).Value = Application.Transpose(vDays)
    
    If UBound(vValues, 2) > (groupNum + (k = 1)) Then
        Range("A" & k).Offset(1).Resize(UBound(vValues, 2) - (groupNum + (k = 1))).EntireRow.Insert
    Else
        If (groupNum + (k = 1) - UBound(vValues, 2)) > 0 Then Range("A" & k).Offset(1).Resize(groupNum + (k = 1) - UBound(vValues, 2)).EntireRow.Delete
        '   Stop
    End If
    
    Range("A" & k).Offset(-(k = 1), 1).Resize(UBound(vValues, 2), groupNum).Value = Application.Transpose(vValues)
Next k

MsgBox "Done"
End Sub

 

[praveenpatel421983]

VBA Geek, You are my man!

It worked perfectly. Thanks a lot for that!

One more help. Small explanation of each line would help me enhance my knowledge and reduce asking this level of question. Please take some time and add some explanation....please.

Sorry for the trouble.

Thanks again
Praveen

 

[VBA Geek]

VBA Geek, You are my man!

It worked perfectly. Thanks a lot for that!

One more help. Small explanation of each line would help me enhance my knowledge and reduce asking this level of question. Please take some time and add some explanation....please.

Sorry for the trouble.

Thanks again
Praveen

yes sure, i added some comments!

[FONT=comic sans ms]Sub trnsp()
Const groupNum As Long = 3 ' number of days t o be transposed, you can also change to 4, 5 6 etc if necessary
Dim k As Long, vDays As Variant, vValues As Variant, lCol As Long

Application.ScreenUpdating = False

For k = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -groupNum ' loop backwards from last row until row 1  stepping each groupNum

    lCol = Rows(k).Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious).Column ' find number of columns for this category
    
    vDays = Range("A" & k).Offset(, 1).Resize(groupNum).Value ' store in array the days
    vValues = Range("A" & k).Offset(, 2).Resize(groupNum, lCol - 2) ' store in array the data
    
    Range("A" & k).Offset(0, 1).Resize(groupNum, lCol - 1).ClearContents ' clear content of the category we are in
    
    If k = 1 Then Range("A" & k).Offset(, 1).Resize(, groupNum).Value = Application.Transpose(vDays) ' if we are in first row paste transpose the days
    
    ' determine the number of rows that need to be inserted
    If UBound(vValues, 2) > (groupNum + (k = 1)) Then
        Range("A" & k).Offset(1).Resize(UBound(vValues, 2) - (groupNum + (k = 1))).EntireRow.Insert
    Else
        If (groupNum + (k = 1) - UBound(vValues, 2)) > 0 Then Range("A" & k).Offset(1).Resize(groupNum + (k = 1) - UBound(vValues, 2)).EntireRow.Delete
    End If
    
    ' paste transpose the data of this category
    Range("A" & k).Offset(-(k = 1), 1).Resize(UBound(vValues, 2), groupNum).Value = Application.Transpose(vValues)
Next k

MsgBox "Done"
End Sub[/FONT]

 

[praveenpatel421983]

Thanks again VBA Geek!