vba loop to copy data and paste it on another worksheet

[lhynlen]

Hi! i need your help in copying the data in Sheet1 and pasting it in Sheet2

I have this data in Sheet1.

The number of rows is unknown but the pattern is the same.

CoumnA	ColumnB
Name
fruit1	pears
fruit2	apple
fruit3	strawberry
fruit4	grapes
fruit5	melon
fruit6	banana
Name
fruit1	apple
fruit2	melon
fruit3	banana
fruit4	strawberry
fruit5	apple
fruit6	grapes
Name
fruit1	banana
fruit2	apple
fruit3	peaches
fruit4	grapes
fruit5	watermelon
fruit6	apple

<tbody>
</tbody>

Basically i want a loop that can copy the data vertically and then pasting it in Sheet2 horizontally.

This is my desired result in Sheet2.

etc1	etc2	fruit1	fruit2	fruit33	fruit4	fruit5	fruit6
		pears	apple	strawberry	grapes	melon	banana
		apple	melon	banana	strawberry	apple	grapes
		banana	apple	peaches	grapes	watermelon	apple

<tbody>
</tbody>

Thanks in advance!

 

[AlphaFrog]

[color=darkblue]Sub[/color] Transpoase_Fruit()
    [color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]With[/color] Sheets("Sheet1")
        [color=darkblue]For[/color] i = 2 [color=darkblue]To[/color] .Range("B" & Rows.Count).End(xlUp).Row [color=darkblue]Step[/color] 7
            Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(, 6).Value = _
                Application.Transpose(.Range("B" & i).Resize(6).Value)
        [color=darkblue]Next[/color] i
    [color=darkblue]End[/color] [color=darkblue]With[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[lhynlen]

I just got the last last row minus the apple in Sheet2

banana

apple

peaches

grapes

watermelon

<tbody>
</tbody>

 

[lhynlen]

anyone?

 

[Kenneth Hobson]

It don't see where etc. etc. columns come from. I guess one might be Name. It looks like you want more of a database sort of transposition rather than a simple transposition. Once you explain my confusion, a solution can be shown that meets your goal.

 

[lhynlen]

just ignore the etc columns in sheet 2, i just added them because i want to start pasting the values in column C/3rd column.

 

[Kenneth Hobson]

Not the most efficient but maybe:

Sub Collate2Cols()
  Dim r As Range, c As Range, a() As Variant, i As Long, j As Long
  
  Set r = Worksheets("Sheet1").Range("A1", _
    Worksheets("Sheet1").Range("A1").End(xlDown))
  a() = UniqueValues(r)
  
  With Worksheets("Sheet2")
    .Range("A1").Resize(, UBound(a)).Value = a()
    For i = 1 To UBound(a)
      j = 1
      For Each c In r
       If a(i) = c.Value Then
          j = j + 1
          .Cells(j, i).Value = c.Offset(, 1).Value
        End If
      Next c
    Next i
  End With
End Sub

'http://msdn.microsoft.com/en-us/library/aa730921.aspx
'http://www.mrexcel.com/forum/showthread.php?t=329212
Function UniqueValues(theRange As Range) As Variant
    Dim colUniques As New VBA.Collection
    Dim vArr As Variant
    Dim vCell As Variant
    Dim vLcell As Variant
    Dim oRng As Excel.Range
    Dim i As Long
    Dim vUnique As Variant
    Set oRng = Intersect(theRange, theRange.Parent.UsedRange)
    vArr = oRng
    On Error Resume Next
    For Each vCell In vArr
    If vCell <> vLcell Then
        If Len(CStr(vCell)) > 0 Then
             colUniques.Add vCell, CStr(vCell)
        End If
    End If
    vLcell = vCell
    Next vCell
    On Error GoTo 0
 
    ReDim vUnique(1 To colUniques.Count)
    For i = LBound(vUnique) To UBound(vUnique)
      vUnique(i) = colUniques(i)
    Next i
 
    UniqueValues = vUnique
End Function

 

[lhynlen]

THIS PROBLEM IS RESOLVED! Both of them works I just adjusted the HEADER PART and works like a CHARM!!! Thank you for all your help