VBA Makro in Excel mehrere Row kopieren


Michael81

Mitglied
Hallo,

ich muss in Excel 2 markierte Zeilen, in ein anderes Tabellenblatt kopieren. Dies mache ich mit "STRG" Zeile anklicken.Aber ich bekomm es nicht hin. Es wird immer nur eine Zeile kopiert außer die Zeilen liegen direkt untereinander. Das bringt mich aber nicht weiter.

Ich habe zur Zeit 2 versuche.
1.
Code:
Sub weiteremethode row kopieren()
Dim Cr As Long, CC As Integer
CC = 1
'Übernehmen der Zeile
Cr = Selection.Row
'Senden an Zieladressen
Cells(Cr, CC).Copy Destination:=Worksheets("Ablage").Range("A1")
Cells(Cr, CC + 1).Copy Destination:=Worksheets("Ablage").Range("A2")
Cells(Cr, CC + 2).Copy Destination:=Worksheets("Ablage").Range("A3")
Cells(Cr, CC + 3).Copy Destination:=Worksheets("Ablage").Range("A4")
Cells(Cr, CC + 4).Copy Destination:=Worksheets("Ablage").Range("A5")

End Sub

und 2.
Code:
Sub d_meldung_ablage()
   ' Dienstliche Meldung ausfullen Makro
   ' Makro am 03.03.2012 von M.Ende erstellt
   
   
   Dim colRng As New Collection
   Dim rng As Range, rngTarget As Range
   Dim iCounter As Integer
   Dim sTarget As String
   For Each rng In Selection.Areas
      colRng.Add rng
   Next rng
   Worksheets("Ablage").Select
   For iCounter = 1 To colRng.Count
      'Set rngTarget = Application.InputBox("Bitte Zielbereich auswählen", Type:=8)
      colRng(iCounter).Copy Rows("42")
   Next iCounter
   Application.CutCopyMode = False
   
  ' Der Makro dmeldung_ausfullen wird gestartet
  Call d_meldung_ausfullen

Hat einer eine Idee?
 
Zuletzt bearbeitet:

Michael81

Mitglied
Ok, Problem ist fast gelöst.
Code:
Selection.EntireRow.Copy Worksheets("Ablage").Cells(1, 1)
Damit kann man mehrere Zeilen in die Ablage packen. Jetzt muss ich nur noch wissen wie man Spalte A im Row überspringt. Da die teilweise verbunden sind z.b. A4,A5 und A37,38. Dann kommt aber ne fehlermeldung.
 

Yaslaw

n/a
Moderator
Mit Excel 2003 getestet
Visual Basic:
Public Function test()
    Dim sourceRange     As Range
    Dim targetRowNr     As Integer
    
    For Each sourceRange In Application.Selection.Areas
        targetRowNr = targetRowNr + 1
        sourceRange.Copy (Worksheets("Sheet2").Range("A" & targetRowNr))
    Next sourceRange
    
    Set sourceRange = Nothing
    
End Function