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.

[TABLE="class: cms_table_grid, width: 200"]
<tbody>[TR]
[TD]CoumnA[/TD]
[TD]ColumnB[/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]fruit1[/TD]
[TD]pears[/TD]
[/TR]
[TR]
[TD]fruit2[/TD]
[TD]apple[/TD]
[/TR]
[TR]
[TD]fruit3[/TD]
[TD]strawberry[/TD]
[/TR]
[TR]
[TD]fruit4[/TD]
[TD]grapes[/TD]
[/TR]
[TR]
[TD]fruit5[/TD]
[TD]melon[/TD]
[/TR]
[TR]
[TD]fruit6[/TD]
[TD]banana[/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]fruit1[/TD]
[TD]apple[/TD]
[/TR]
[TR]
[TD]fruit2[/TD]
[TD]melon[/TD]
[/TR]
[TR]
[TD]fruit3[/TD]
[TD]banana[/TD]
[/TR]
[TR]
[TD]fruit4[/TD]
[TD]strawberry[/TD]
[/TR]
[TR]
[TD]fruit5[/TD]
[TD]apple[/TD]
[/TR]
[TR]
[TD]fruit6[/TD]
[TD]grapes[/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]fruit1[/TD]
[TD]banana[/TD]
[/TR]
[TR]
[TD]fruit2[/TD]
[TD]apple[/TD]
[/TR]
[TR]
[TD]fruit3[/TD]
[TD]peaches[/TD]
[/TR]
[TR]
[TD]fruit4[/TD]
[TD]grapes[/TD]
[/TR]
[TR]
[TD]fruit5[/TD]
[TD]watermelon[/TD]
[/TR]
[TR]
[TD]fruit6[/TD]
[TD]apple[/TD]
[/TR]
</tbody>[/TABLE]



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.

[TABLE="class: cms_table_grid, width: 200"]
<tbody>[TR]
[TD]etc1[/TD]
[TD]etc2[/TD]
[TD]fruit1[/TD]
[TD]fruit2[/TD]
[TD]fruit33[/TD]
[TD]fruit4[/TD]
[TD]fruit5[/TD]
[TD]fruit6[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]pears[/TD]
[TD]apple[/TD]
[TD]strawberry[/TD]
[TD]grapes[/TD]
[TD]melon[/TD]
[TD]banana[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]apple[/TD]
[TD]melon[/TD]
[TD]banana[/TD]
[TD]strawberry[/TD]
[TD]apple[/TD]
[TD]grapes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]banana[/TD]
[TD]apple[/TD]
[TD]peaches[/TD]
[TD]grapes[/TD]
[TD]watermelon[/TD]
[TD]apple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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

[TABLE="class: cms_table_cms_table_grid, width: 200"]
<tbody>[TR]
[TD]banana[/TD]
[TD]apple[/TD]
[TD]peaches[/TD]
[TD]grapes[/TD]
[TD]watermelon[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[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