Frage von PunkGirly, 24

VBA für Listenwerte kopieren?

Ich habe eine Liste mit 100 Einträgen und ich brauche jede Zeile 36x untereinander kopiert. Wie kann man das mit VBA einrichten?

Antwort
von geri3d, 15

Ganz einfach mit einer For-Schleife. Damit der liebe Suboptimierer auch einen Stern für seine Arbeit bekommt.

Expertenantwort
von Suboptimierer, Community-Experte für Excel, 18
Sub ItemsUebertragen()
  Dim i, j As Integer
  For i = 0 To ComboBox1.ListCount - 1
    For j = 1 To 36
      Range("A" & (i * 36 + j)).Value = ComboBox1.List(i)
    Next
  Next
End Sub
Expertenantwort
von Iamiam, Community-Experte für Excel, 12

Da ich keine Ahnung habe, warum Subopt mit Combobox arbeitet (steh ich da komplett auf dem Schlauch?), habe ich ein alternatives µ kreiert (auch kaum komplizierter):

Sub Zeilen35xkopierenPlusOriginal()
Dim R As Integer, rmax As Integer, i As Integer
rmax = ActiveSheet.Range("A2").End(xlDown).Row
For R = rmax To 1 Step -1
For i = 1 To 35
Rows(R).Copy
Rows(R + 1).EntireRow.Insert
Next i
Next R
End Sub

Wichtig: das µ muss von unten nach oben arbeiten, das sich sonst die Zeilenbezüge ständig ändern würden. Aber so tutets, habs mit 5 Einträgen und 3 Kopien (also 4 Ergebniszeilen ausprobiert).

Beim vorgegebenen Umfang läuft es vllt ein Weilchen, aber sicher nicht extrem lang.

Leerzeilen dazwischen würden allerdings die Erfassung der Zeilenzahl stören:

probier erst mal aus, ob Du mit Ende-PfeilNachUnten auch wirklich zur letzten zu kopierenden Zeile kommst. Auch würden Leerzeilen mitvervielfältigt.

Bei dieser Anlage stören Einträge unterhalb NICHT, WENN EINE LEERZEILE DAZWISCHEN ist.

Um Leerzeilen in der Liste zu ignorieren, bedürfte es eines geringen Mehraufwands (Abfrage, ob in der Zeile was steht, dauert auch nicht viel länger)

Sub Zeilen35xkopierenPlusOriginalVar1() 'Leerzeilen bleiben einfach erhalten
Dim R As Integer, rmax As Integer, i As Integer
'rmax = ActiveSheet.Range("A2").End(xlDown).Row '<geändert zu:
rmax = ActiveSheet.Range("A999999").End(xlUp).Row
For R = rmax To 1 Step -1
For i = 1 To 35
If Application.CountA(Rows(R).Cells) > 0 Then
Rows(R).Copy
Rows(R + 1).EntireRow.Insert
End If
Next i
Next R
End Sub

in diesem Falle dürfte allerdings unter dem letzten A der Liste nichts mehr stehen.

Keine passende Antwort gefunden?

Fragen Sie die Community