Microsoft Excel

Herbers Excel/VBA-Archiv

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

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"