PDA

Vollständige Version anzeigen : Bereiche kopieren/einfügen und mittels Loop "automatisieren"


wuli
19.12.2017, 10:40
Hallo liebes MS Office Forum,

da ich noch ein VBA Anfänger bin bräuchte ich bitte eure Hilfe :)

Zu meinem Problem:

Ich möchte im Arbeitsblatt 1 einen definierten Bereich kopieren und in Arbeitsblatt 2 einfügen. Das ganze soll sich anschließend wiederholen bis eine leere Zeile (in Arbeitsblatt 1) ist.

Momentan verwende ich folgenden Code:

Sub Kopieren()
'Bereich kopieren
Sheets("Arbeitsblatt1").Range("A10:B20").Copy
'einfügen in erste freie Zeile in ausgabe
Sheets("Arbeitsblatt2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Kopiermodus beenden
Application.CutCopyMode = False
End Sub

Nun möchte ich gerne das ganze "automatisieren" mittels Loop.

Es sollen solange die Werte aus Arbeitsblatt1 kopiert und in Arbeitsblatt2 eingefügt werden bis eine Leere Zeile in Arbeitsblatt1 vorkommt.

Das ganze sollte flexibel sein da die Anzahl der Werte unterschiedlich ist in Arbeitsblatt1. Ich möchte immer A10:B20, A30:B40, A50:B60, usw. (bis Leerzeile)... kopieren und anschließend in Arbeitsblatt2 einfügen ;)

Kann mir bitte jemand weiter helfen?

Lieben Dank im Voraus,

Lg Flo

Jonas0806
19.12.2017, 10:53
Hallo Flo,

was genau meinst Du mit "bis Leerzeile"? Was steht denn z.B. in A21:B29?

Könntest Du Dein Vorhaben mal anhand einer Beispieldatei erläutern? Bitte lade die Datei als *.xlsx, ohne Makros hoch. Es gibt da wesentlich performantere Wege. als das einzelne Kopieren.

wuli
19.12.2017, 11:03
Hallo Jonas,

danke für die schnelle Antwort :)
Im Anhang eine Beispieldatei.

Lg Flo

Uwi63
19.12.2017, 11:20
Hallo Flo,
mein Vorschlag:
Sub Kopieren2()
Dim rng As Range
Dim iVersatz As Integer
iVersatz = 20

'Start
Set rng = Sheets("Arbeitsblatt1").Range("A10")

Do While rng <> ""
rng.Resize(11, 2).Copy Sheets("Arbeitsblatt2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Set rng = rng.Offset(iVersatz, 0)
Loop

End Sub

Jonas0806
19.12.2017, 11:30
Hallo Flo,

mein Vorschlag, der bei größeren Datenmengen etwas robuster ist. Habe den jetzt allerdings nicht durchgetestet

Option Explicit

Sub Kopieren()
Dim i As Long, j As Long, k As Long
Dim arr()

With Tabelle1
For i = 10 To .Cells(1, 1).End(xlDown).Row - 10 Step 20
ReDim Preserve arr(j)
arr(j) = .Cells(i, 1).Resize(11, 2)
j = j + 1
Next i
End With

For k = LBound(arr) To UBound(arr)
With Tabelle2
.Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(11, 2) = arr(k)
End With
Next k
End Sub

wuli
19.12.2017, 11:55
Hallo Uwe und Jonas,

vielen Dank euch beiden.

Beide Varianten funktionieren einwandfrei!

Danke für die schnellen Antworten

Beste Grüße
Flo

wuli
20.12.2017, 10:51
Hallo,

ich hätte noch eine Frage bezüglich dem Code:

Ich verwende momentan diesen (Abwandlung des Codes von Uwe):


Sub Führungen()
Dim rng As Range
Dim iVersatz As Integer
iVersatz = 110
Cells.Clear
'Start
Set rng = Sheets("Kurvenauswertung").Range("W7")

Do While rng < 0 > ""
rng.Resize(1, 1).Copy Sheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
Set rng = rng.Offset(iVersatz, 0)
Loop
Sheets("Anleitung für Auswertung").Select
End Sub


Damit auch leere Zeilen (welche in Kurvenauswertung vorhanden sind) auf die Tabelle1 bekomme habe ich bei
Do While rng < 0 > ""
eine Null eingefügt.

Nun mein Problem: Es werden alle Werte ausgegeben aber es kommt zum Schluss immer diese Fehlermeldung: Laufzeitfehler `1004' Anwendungs- oder objektdefinierter Fehler.

Da die Rechendauer dieses Makros relativ lang ist vermute ich dass bis "unendlich" gerechnet wird und der Fehler dadurch auftritt.

Hat jemand eine Idee?

Vielen Dank im Voraus,

beste Grüße Flo

Uwi63
20.12.2017, 11:39
Hallo Flo,

zunächst empfehle ich Dir, den Code mal im Einzelschritt ablaufen zu lassen und dann zu beobachten an welcher Stelle im Code dein Fehler erscheint.
Dazu im Codebereich mit der Taste F8 durch dein Makro bewegen.
Zeitgleich kann man dann einen Blick auf die Blätter werfen um zu sehen was passiert.
Allerdings ist dann darauf zu achten was im Code wie aufgerufen wird:
z.B. würde Cells.Clear alle Zellwerte deines aktiven Blatts löschen, was möglicherweise fatal wäre, wenn das Blatt aus dem Du lesen möchtest, gerade aktiv wäre...
Besser wäre auf jeden Fall hier dem Befehl, das Blatt, welches Du löschen möchtest, voranzustellen, nämlich z.B. so:
Sheets("Tabelle1").Cells.Clear

Do While rng <> "" heißt soviel wie :
Tu was, solange rng ungleich Leer ist
'<> kann man also nicht trennen, oder eine Null dazwischen schreiben!
Wenn Du mehrere Abfragen hitereinander machen möchtest, musst Du sie verbinden, z.B. so:
If rng <> "" And rng < 0
was in diesem Fall aber auch keinen Sin machen würde, weil, wenn der Zellwert kleiner Null ist, dann ist er auch nicht Leer, also brauch ich das nicht abfragen.

Vielleicht solltest Du auch nochmal eine Beispieldatei hochladen, die Dein Wunschergebnis beschreibt, momentan kann ich nicht nachvollziehen, was Leerzeilen betrifft, einerseits soll es nur solange laufen bis eine Leerzeile auftritt, andererseits ???

wuli
20.12.2017, 11:58
Hallo Uwe,

vielen Dank für deine Antwort.

Im Anhang ein Beispiel mit Erklärung.

(Danke auch für deine Tipps, ich bin noch ein richtiger VBA-Anfänger :upps: :D )

Lg Flo

Uwi63
20.12.2017, 13:09
Hallo Flo,
das würd ich dann z.B. so machen:
Sub Führungen()
Dim rng As Range
Dim lngLetzte As Long
Dim iVersatz As Integer
iVersatz = 4

Sheets("Arbeitsblatt2").Range("A25").CurrentRegion.Offset(1).Clear 'zusammenhängende Region um 1 Zeile nach unten löschen (=Kopfzeile bleibt erhalten)

With Sheets("Arbeitsblatt1")
'Start
Set rng = .Range("A14")
lngLetzte = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row 'letze in Spalte 'A' beschriebene Zeile

Do While rng.Row <= lngLetzte 'solange Zeile kleiner/gleich LetzteZeile
If rng <> "" Then 'nur wenn Zelle NICHT LEER
rng.Resize(1, 1).Copy Sheets("Arbeitsblatt2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Set rng = rng.Offset(iVersatz, 0)
Loop
End With

End Sub

wuli
20.12.2017, 21:13
Hallo Uwe,

funktioniert einwandfrei.

Wie auch schon letztes Mal hast du mir enorm geholfen :)

Danke dafür :)

Beste Grüße,
Flo