x aantal keer tekst onder elkaar plakken in vba

[dekrant]

Beste,

Ik heb een excelbestand met een variabel aantal kolommen. In de eerste kolom staan namen en in de overige kolommen staan waarden. Nu wil ik deze waarden in een nieuw tabblad onder elkaar presenteren. Hiervoor wil ik in eerste instantie de namen net zo vaak onder elkaar kopieren als er kolommen gevuld zijn.
Voor dit laatste stuk heb ik geprobeerd een macro te schrijven, maar wat doe ik fout?

Sub test()
Dim teller As Integer
Dim i As Integer

teller = WorksheetFunction.CountA(Rows(1))
Do While i < teller
i = i + 1
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheet2.Cells(Range("A1000").End(xlUp).row, 1).Paste
Loop
End Sub

Kan iemand mij helpen.
bij voorbaat dank

De krant

 

[snb]

Is dit dezelfde vraag als hier ?

http://www.helpmij.nl/forum/showthread.php/848453-Vba

 

[edmoor]

Een voorbeeld bestandje zal je sneller aan een oplossing helpen.

 

[dekrant]

Beste SNB en Edmoor

Wat ik bedoel is niet hetzelfde als de link die je me gaf.
Hierbij een voorbeeld bestandje.
Nu staat de naam in kolom A met daarachter een aantal waarden.
Deze wil ik onder elkaar weer geven in Sheet 2. Ik ben in mijn macrootje begonnen met de namen in kolom A van Sheet 2 net zo vaak te kopieren als er kolommen zijn in sheet 1.

Helaas na veel geknutsel is het me nog niet gelukt. Ik hoop dat jullie me kunnen helpen.

Dankje
groeten
de Krant

 

[edmoor]

Probeer deze maar eens:

Sub Test()
    Dim Einde As Long
    Dim x As Long
    Dim y As Long
    Dim z As Long
    
    Einde = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
    z = 1
    
    For x = 2 To Einde
        For y = 1 To 5
            Sheets("Sheet2").Cells(z, 1) = Sheets("Sheet1").Cells(x, y)
            z = z + 1
        Next y
    Next x
End Sub

 

[HSV]

Of met één schrijfbeweging.

Sub hsv()
Dim sn, i As Long, j As Long, n As Long, arr
With Sheets(1)
sn = .Cells(1).CurrentRegion
ReDim arr(UBound(sn, 1) * UBound(sn, 2), 1)
  For i = 2 To UBound(sn, 1)
  For j = 2 To UBound(sn, 2)
    If Not IsEmpty(sn(i, j)) Then
         arr(n, 0) = sn(i, 1)
         arr(n, 1) = sn(i, j)
       n = n + 1
     End If
    Next j
   Next i
    With Sheets(2).Cells(1)
     .CurrentRegion.ClearContents
     .Resize(n, 2).Value = arr
   End With
 End With
End Sub

 

[dekrant]

Dank jullie wel. Dit werkt perfect.
Nu ga ik kijken of ik het ook nog snap

Groeten
de Krant