Microsoft Excel

Herbers Excel/VBA-Archiv

Kopieren und einfuegen

Betrifft: Kopieren und einfuegen von: Steve
Geschrieben am: 17.09.2014 08:50:46

Hallo!

Da mir gerade schon so gut und schnell geholfen werden konnte hab ich hier gleich nochmal ein Problem.

Ausgangslage ist, dass Zeile A1 bis F1 gefüllt ist. Danach kommen 95 Leerzeilen und in A97 bis F97 stehen wieder Daten. Ich möchte jetzt jeweils den Inhalt von A1 bis F1 in die darunter liegenden 95 Leerzeilen kopieren und anschließend widerum A97 bis F97 in die darunter liegenden 95 Leerzeilen kopieren. Der Vorgang soll so lange laufen bis nach den 95 Leerzeilen in Spalte A bis F kein Eintrag mehr vorhanden ist, der kopiert werden kann.

Momentan hab ich das so gelöst. Er kopiert mir hier aber nur die A1 bis F1 für die nächsten 95 Zeilen und bei den nächsten Zeilen funktioniert das nicht mehr. Bisher muss ich auch noch die Schleifendurchläufe eingeben, war erstmal zum Testen angedacht.

Sub copypaste()
Application.ScreenUpdating = False
For i = 1 To 10
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1:F95").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=84
    ActiveCell.Offset(95, 0).Range("A1").Select
Next i
Application.ScreenUpdating = True
End Sub
Ich denke ich bauch hier irgendwie ne allgemeinere Version, die für mich passt :/ Kann mir jemand helfen?

Beste Grüße,
Steve

  

Betrifft: AW: Kopieren und einfuegen von: Robin Heiming
Geschrieben am: 17.09.2014 12:38:20

Grüße Steve,

ich bin jetzt davon ausgegangen das in der jeweiligen Zeilen-Spalte A immer etwas steht, wusste nicht ob es lückenlos ist. Aber hoffentlich konnte ich dir hiermit behilflich sein:

Sub DoWhile()

    Application.ScreenUpdating = False

    Dim a, b, c, d, x As Integer
    
    a = 1
    b = 1
    c = 1
    d = 6
    
    Do
    
        If Cells(a, b) = "" Then
        
            Exit Sub
    
        Else
        
            Range(Cells(a, b), Cells(c, d)).Copy
            Range(Cells(a + 1, b), Cells(c + 95, d)).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            
        End If
        
    a = a + 96
    c = c + 96

    Loop Until Cells(a, b) = ""
    
    Application.ScreenUpdating = True
    
    Cells(a, b).Activate
    
End Sub
ansonsten kannst du gerne nochmal nachfragen oder mich auf Fehlern hinweisen.

MfG
RoHb


  

Betrifft: AW: Kopieren und einfuegen von: Rudi Maintaire
Geschrieben am: 17.09.2014 12:39:32

Hallo,

Sub aa()
  Dim i As Long
  Application.ScreenUpdating = False
  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 96
    Cells(i, 1).Resize(, 6).Copy
    Cells(i + 1, 1).Resize(95).PasteSpecial xlPasteValues
  Next
  Application.CutCopyMode = False
End Sub
Gruß
Rudi


  

Betrifft: AW: Kopieren und einfuegen von: Steve
Geschrieben am: 17.09.2014 13:36:21

Vielen Dank Rudi.

Funktioniert super. Hatte es mittlerweile auch etwas uneleganter gelöst.


 

Beiträge aus den Excel-Beispielen zum Thema "Kopieren und einfuegen"