Herbers Excel/VBA-Archiv

VBA Wenn dann Zelle 5x kopieren in nächste Leere

• VBA Wenn dann Zelle 5x kopieren in nächste Leere von Max vom 29.07.2014 08:57:02
• AW: VBA Wenn dann Zelle 5x kopieren in nächste Leere - von Rudi Maintaire am 29.07.2014 11:05:06

Betrifft: VBA Wenn dann Zelle 5x kopieren in nächste Leere von: Max
Geschrieben am: 29.07.2014 08:57:02

Hallo *,

ich würde mich freuen, wenn ihr mir weiterhelfen könnt.

Wenn in Zelle A1 beispielsweise etwas steht, dann würde ich gerne die Zellen A1,B1,D1,E1 und G1 auf ein neues Tabellenblatt kopieren. Aber nicht nur einmal, sondern 5x untereeinander.

In Zeile 2 meiner Tabelle steht natürlich auch ein Wert, somit sollen dann auch A2, B2, D2, E2 und G2 5x auf das neue Tabellenblatt kopiert werden, allerdings in die ersten freien Zeilen.

Könnt ihr mir dafür eine Excel-Schleife vorschlagen?

Grüße,

Max

Betrifft: AW: VBA Wenn dann Zelle 5x kopieren in nächste Leere von: Rudi Maintaire
Geschrieben am: 29.07.2014 11:05:06

Hallo,

Sub abc()
  Dim wsAkt As Worksheet, wsNeu As Worksheet
  Dim rngC As Range
  Dim arrTmp(1 To 5, 1 To 5), i As Integer
  Application.ScreenUpdating = False
  Set wsAkt = ActiveSheet
  Set wsNeu = Worksheets.Add(after:=wsAkt)
  With wsAkt
    For Each rngC In .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
      If rngC <> "" Then
        For i = 1 To 5
          arrTmp(i, 1) = rngC.Offset(, 0)
          arrTmp(i, 2) = rngC.Offset(, 1)
          arrTmp(i, 3) = rngC.Offset(, 3)
          arrTmp(i, 4) = rngC.Offset(, 4)
          arrTmp(i, 5) = rngC.Offset(, 6)
        Next
        wsNeu.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arrTmp), UBound(arrTmp, 2)) _
 = arrTmp
      End If
    Next
  End With
  wsNeu.Rows(1).Delete
End Sub

Gruß
Rudi

Beiträge aus den Excel-Beispielen zum Thema "VBA Wenn dann Zelle 5x kopieren in nächste Leere"