Mehrer Tabellenblätter in eine neue Tabelle kopieren

Question

Hallo zusammen,

ich habe eine Tabelle bestehend aus ca. 25 Tabellenblättern.

20 davon möchte ich gerne über ein Makro untereinander in ein neues Tabellenblatt kopieren (Aufbau ist identisch).

Nur haben die Tabellenblätter einen Haken, sie erzeugen ihren Namen nämlich selber (auch über ein Makro).

Kann ich das dann noch über ein Makro lösen? Findet das "KopierMakro" die TAbellen noch wenn sich monatlich die Registernamen ändern?

Gruß Lefty

Answer 1

Oha, hab es schon selber herrausgefunden.

'Bereich kopieren und Werte im Arbeitsblatt Hilfstabelle einfügen
With ThisWorkbook.Worksheets(blatt)
.Range(.Cells(9, 1), .Cells(lzquelle, lzspalte)).Copy

Answer 2

Hallo,

sorry, hatte ich übersehen.
Ändere

With ThisWorkbook.Worksheets(blatt)
.Range(.Cells(1, 1), .Cells(lzquelle, lzspalte)).Copy
End With

in

With ThisWorkbook.Worksheets(blatt)
.Range(.Cells(9, 1), .Cells(lzquelle, lzspalte)).Copy
End With

Gruß

M.O.

Answer 3

Hallo,

da hatten sich die Post überschnitten :-).

Gruß

M.O.

Answer 4

Hi M.O.,

an dieser Stelle noch eine Frage zum Thema:

Wie muss das Makro aussehen, wenn ich möchte das ähnlich wie oben, wieder aus allen Tabellen die mit "Erhebung" beginnen. Nur Zeilen Kopiert werden bei denen in Spalte H der Inhalt mit TAXI, PKW oder MINICAR beginnt?

Das ganze soll dann in der Tabelle "Fuhrpark" landen und auch wie beim letzten mal soll es beim monatlichen aktualisieren erstmal die alten Daten löschen.

Danke schonmal, Gruß Lefty

Answer 5

Hallo Lefty,

probier es mal mit den folgenden Makro:

Sub kopieren2()

Dim blatt, lzziel, lzspalte, lzquelle, zeile As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Daten in Hilfstabelle löschen
'letzte Zeile in Hilfstabelle ermitteln - ggf. Schreibweise des Namens anpassen
lzziel = ThisWorkbook.Worksheets("Fuhrpark").UsedRange.SpecialCells(xlCellTypeLastCell).Row
lzspalte = ThisWorkbook.Worksheets("Fuhrpark").UsedRange.SpecialCells(xlCellTypeLastCell).Column
'Bereich löschen - ab Zeile 13
ThisWorkbook.Worksheets("Fuhrpark").Range(Cells(13, 1), Cells(lzziel, lzspalte)).ClearContents

'Kopieren
For blatt = 1 To ThisWorkbook.Worksheets.Count

'Prüfung, ob Blatt mit Erhebung beginnt
If Left(ThisWorkbook.Worksheets(blatt).Name, 8) = "Erhebung" Then
'falls ja, letzte Zeile und Spalte und des Blattes ermitteln
lzquelle = ThisWorkbook.Worksheets(blatt).UsedRange.SpecialCells(xlCellTypeLastCell).Row
lzspalte = ThisWorkbook.Worksheets(blatt).UsedRange.SpecialCells(xlCellTypeLastCell).Column
'Schleife zum Prüfen, ob in Spalte H die Inhalte mit TAXI, PKW oder MINICAR beginnen - ab Zeile 1
For zeile = 1 To lzquelle
If Left(ThisWorkbook.Worksheets(blatt).Cells(zeile, 8), 4) = "TAXI" Or Left(ThisWorkbook.Worksheets(blatt).Cells(zeile, 8), 3) = "PKW" Or Left(ThisWorkbook.Worksheets(blatt).Cells(zeile, 8), 7) = "MINICAR" Then
'letzte Zeile im Blatt Fuhrpark ermitteln
lzziel = ThisWorkbook.Worksheets("Fuhrpark").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If lzziel < 13 Then lzziel = 13 'Zeile ändern, falls Zeile kleiner als 13
'Bereich kopieren und Werte im Arbeitsblatt Fuhrpark einfügen
With ThisWorkbook.Worksheets(blatt)
.Range(.Cells(zeile, 1), .Cells(zeile, lzspalte)).Copy
End With
ThisWorkbook.Worksheets("Fuhrpark").Cells(lzziel, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next zeile
End If

Next blatt

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Das Makro gehört in ein allgemeines Modul deiner Tabelle.

Gruß

M.O.

Answer 6

Hat sofort so funktioniert wie ich es mir vorgestellt habe.

DANKE ! ! !

Frohe Festtage, Gruß Lefty

Answer 7

Hallo Lefty,

gern geschehen und auch dir ein frohes Fest.

Gruß

M.O.