Excel Makro Inhalt kopieren

Question

Hallo Leute
Ich bräuchte ein wenig Hilfe bei einem Makro.

Ich würde gerne von Tabellenblatt A ca 30.000 Zellen in Tabellenblatt B kopieren

Sub Tabellekopieren()

Range("B1").CurrentRegion.Select
Selection.Copy
Sheets("Tabellenblatt A").Select
Sheets("Tabellenblatt B").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveSheet.Paste
End Sub

nun soweit käme ich ja aber


Da ich aber in Tabellenblatt B stetig die Spalten befülle müsste das Makro folgendes tun.

Kontrollieren welche Spalte hat genug Zellen frei zum einfügen
Also wenn Spalte A nicht genug Zellen frei dann zu Spalte B wenn B voll dann zu Spalte C usw...
Wenn genug Platz in einer Spalte gefunden dann in die 2. Leere Zelle Inhalt einfügen.
Wäre das irgendie umsetzbar?
Kann mir da jemand vielleicht helfen

Wäre nett

Answer 1

Hallo,

du schreibst

Also wenn Spalte A nicht genug Zellen frei dann zu Spalte B wenn B voll dann zu Spalte C usw...

Ich nehme mal an, dass du immer nur eine Spalte (die Spalte B?) kopieren willst. Mit
dem Befehl

Range("B1").CurrentRegion.Select

wählst du aber einen zusammenhängenden beschriebenen Bereich aus, der ggf. auch aus mehreren Spalten bestehen kann.

Und was meinst du mit "nicht genug Zellen frei"? Meinst du damit die Gesamtanzahl der Zeilen?

Gruß

M.O.

Answer 2

Hi M.O

erstmal danke für eine Antwort

ich habe mich schlecht ausgedrückt ja ich will gerne nur die Spalte B mit ca 30.000 Zellen (ist Variabel mal mehr mal weniger)
in ein neues Tabellenblatt Spalte A kopieren.
Da ich ja fast täglich die Spalte A mit neuen Zellen befülle werden die Zellen täglich weniger
jetzt würd ich das gerne mit einem Makro machen.

Das Makro soll folgendes machen:

Kopier die 30.000 Zellen von Spalte B In neues Tabellblatt Spalte A, sollte Spalte A keine
30.000 Zellen frei haben dann in Spalte B kopieren, Sollte Spalte B keine 30.000 Zellen frei haben
dann in Spalte C usw....
Er soll schauen in welcher Spalte Platz ist und dorthin kopieren mit 1 Leerzeile dazwischen für die nächsten 30.000 oder mehr Zellen.

Ich hoffe ich habe mich verständlich ausgedückt.
Wäre dies irgendwie Möglich

lg
Robert

Answer 3

Hallo Robert,

das folgende Makro sollte dein Problem lösen:

Sub kopieren()
Dim lngLetzteA As Long
Dim lngLetzteB As Long
Dim lngMaximum As Long
Dim lngSpalte As Long

'Maximale Anzahl der Zeilen in Tabelle ermitteln
lngMaximum = ActiveSheet.Rows.Count

'letzte beschriebene Zeile in Spalte A in "Tabellenblatt A" ermitteln
With ThisWorkbook.Worksheets("Tabellenblatt A")
lngLetzteA = .Cells(.Rows.Count, 2).End(xlUp).Row
End With

'Schleife zum Finden der Spalte, in der die Daten eingefügt werden sollen
Do
'Nun in "Tabelle B" die Spalten prüfen, ob genügend Platz vorhanden
'Spaltenzähler um 1 erhöhen
lngSpalte = lngSpalte + 1

'letzte beschriebene Zeile in Spalte A in "Tabellenblatt B" ermitteln
With ThisWorkbook.Worksheets("Tabellenblatt B")
lngLetzteB = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
End With

'Schleife verlassen, wenn die Anzahl der zu kopierenden Zellen in Spalte passt
Loop Until lngLetzteA < lngMaximum - lngLetzteB

'Daten in gefundene Spalte kopieren
With ThisWorkbook.Worksheets("Tabellenblatt A")
.Range(.Cells(1, 2), .Cells(lngLetzteA, 2)).Copy
End With

With ThisWorkbook.Worksheets("Tabellenblatt B")
.Cells(lngLetzteB, lngSpalte).PasteSpecial Paste:=xlPasteValues
End With

'Copy-Markierung aufheben
Application.CutCopyMode = False

End Sub

Das Makro gehört in ein Standard Modul deiner Tabelle. Die Namen der Arbeitsblätter musst du ggf. noch anpassen.

Gruß

M.O.

Answer 4

Hi M.O

Vielen Dank fürs Makro es funktioniert Super

Ich hätte noch 2 Fragen
Ist es Möglich bei
'letzte beschriebene Zeile in Spalte A in "Tabellenblatt A" ermitteln
eine Leerzeile dazwischen zu machen und dann die Daten zu kopieren
also quasi in der 2. freien Zeile .

Und wenn ich mehre Spalten kopieren möchte was müsste ich im Makro ändern
um nicht nur Spalte B sonder auch z,b D,E,usw. zu kopieren.

lg
Robert

Answer 5

Hallo Robert,

bei deiner Frage wegen der freien Zeile habe ich gesehen, dass im Makro noch ein kleiner Fehler ist (die letzte Zeile eines bereits eingefügten Bereichs wird überschrieben). Anbei das verbesserte Makro mit leerer Zelle nach dem letzten eingefügten Bereich:

Sub kopieren()
Dim lngLetzteA As Long
Dim lngLetzteB As Long
Dim lngMaximum As Long
Dim lngSpalte As Long

'Maximale Anzahl der Zeilen in Tabelle ermitteln
lngMaximum = ActiveSheet.Rows.Count

'letzte beschriebene Zeile in Spalte A in "Tabellenblatt A" ermitteln
With ThisWorkbook.Worksheets("Tabellenblatt A")
lngLetzteA = .Cells(.Rows.Count, 2).End(xlUp).Row
End With

'Schleife zum Finden der Spalte, in der die Daten eingefügt werden sollen
Do
'Nun in "Tabelle B" die Spalten prüfen, ob genügend Platz vorhanden
'Spaltenzähler um 1 erhöhen
lngSpalte = lngSpalte + 1

'letzte beschriebene Zeile in Spalte in "Tabelle B" ermitteln
With ThisWorkbook.Worksheets("Tabellenblatt B")
lngLetzteB = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
End With

If lngLetzteB > 1 Then lngLetzteB = lngLetzteB + 2

Loop Until lngLetzteA < lngMaximum - lngLetzteB

'Daten in gefundene Spalte kopieren
With ThisWorkbook.Worksheets("Tabellenblatt A")
.Range(.Cells(1, 2), .Cells(lngLetzteA, 2)).Copy
End With

With ThisWorkbook.Worksheets("Tabellenblatt B")
.Cells(lngLetzteB, lngSpalte).PasteSpecial Paste:=xlPasteValues
End With

'Copy-Markierung aufheben
Application.CutCopyMode = False

End Sub

Wenn du mehrere Spalten einfügen willst, dann bedenke, dass immer nur eine Spalte geprüft wird, ob genügend Platz zum Einfügen zur Verfügung steht.
Wenn du dann mehrere Spalten kopierst werden ggf. vorhandene Daten in den folgenden Spalten überschrieben. Und die Größe des zu kopierenden Bereichs wird weiterhin über Spalte B bestimmt.

Willst du z.B. die Spalten B bis D kopieren, dann ändere das Makro wie folgt:

'Daten in gefundene Spalte kopieren
With ThisWorkbook.Worksheets("Tabellenblatt A")
'Spalten B = 2 bis D = 4 kopieren
.Range(.Cells(1, 2), .Cells(lngLetzteA, 4)).Copy
End With

Gruß

M.O.

Answer 6

Was soll ich sagen es läuft Perfekt

Vielen Dank für deine Bemühungen und Hife

lg
Robert