Aufteilung einer umfangreichen Excel Tabelle in kleine Tabellen

Question

Hallo,

ich habe eine ziemlich lange Excel Tabelle die ich in einzelne Tabellen zerlegen muss. Die Spalten, die in die neue Tabelle sollen sind jeweils mit einer Zahl markiert, die ersten 10 Spalten mit einer 1, die nächsten 6 Spalten mit einer 2 usw. Ich hatte an ein Makro gedacht, dass nach der Zahl sucht und alle Spalten, die zu der Zahl passen in eine neue Excel Datei kopiert und der Datei den Namen der Zahl gibt und dann in einem Ordner abspeichert.
Hat jemand eine Idee?

vielen Dank für Eure Hilfe

Richard

Answer 1

Hallo,

in welcher Zeile stehen denn die Zahlen, die angeben, welche Spalte zusammen gehören?

Gruß

M.O.

Answer 2

Hallo M.O.

die Zahlen stehen in der ersten Zeile. etwa so
Zeile1,Zeile2,Zeile3,Zeile4
Nr , Info1, Info2 , Info3
Spalte1 1 3,6 1,9 5,3
Spalte2 1 5,7 2,8 9,6
Spalte3 1 4,0 4,8 7,8
Spalte4 2
Spalte5 2
Spalte6 3
Spalte7 3
Spalte8 3
Spalte9 3

usw
jetzt sollen die ersten 3 Spalten in eine Datei, die Spalten 4 und 5 in die zweite, die Spalten 6 bis 9 in die dritte. In Wirklichkeit handelt es sich um deutlich mehr Spalten
Ich hoffe, ich konnte Dir die gewünschte Information geben
viele Grüße

Richard

Answer 3

Hallo Richard,

eine Frage habe ich noch :-). Welche Excel-Version hast du?

Gruß

M.O.

Answer 4

Hallo Richard,

vergiss meine Frage :-).

Hier der Code. Du musst nur den Pfad anpassen:

Sub spalten_kopieren()

Dim wbkn, wbkq, tabq, Ziel, Pfad, Name As String
Dim spalte, espalte, lspalte, ls, nummer As Integer

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Hier den Pfad zur Speicherung der Datei eingeben
Pfad = "C:\Test\"

'Name der geöffneten Datei und Tabellenblatt in Variable schreiben
wbkq = ActiveWorkbook.Name
tabq = ActiveSheet.Name

'letzte Spalte im aktiven Blatt wird ermittelt
ls = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column

'Die Variablen werden geschrieben
espalte = 1 'erste Spalte, die kopiert werden soll
nummer = ActiveSheet.Cells(1, 1) 'Nummer aus Spalte 1


'Prüfen, welche Spalten die selbe Nummer haben
For spalte = 2 To ls
If ActiveSheet.Cells(1, spalte) <> nummer Or spalte = ls Then

'neue Arbeitsmappe erstellen
Set neuesWB = Workbooks.Add
wbkn = neuesWB.Name
'aus neuer Arbeitsmappe alle Blätter bis auf das Erste herauslöschen
Application.DisplayAlerts = False
While Worksheets.Count > 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True

'letze Spalte zum kopieren wird festgelegt
If spalte = ls Then
lspalte = spalte
Else
lspalte = spalte - 1
End If

'kopieren
Workbooks(wbkq).Activate
Workbooks(wbkq).Worksheets(tabq).Range(Columns(espalte), Columns(lspalte)).EntireColumn.Copy
Workbooks(wbkn).Worksheets(1).Paste
Application.CutCopyMode = False

'Speichern der neuen Mappe
With Workbooks(wbkn)
.SaveAs Filename:=Pfad & nummer
.Close
End With

'wieder zur Quelle zurück
Workbooks(wbkq).Activate

'Variablen werden neu geschrieben
espalte = spalte
nummer = ActiveSheet.Cells(1, spalte)

End If

Next spalte

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 5

Hallo M.O.

vielen Dank für den Code. Das makro legt auch gleich mächtig los, aber irgendwie kopiert es die erste Zeile des Datenblattes in die Datei und möchte ständig die Dateien ersetzen. Ich versuch mal, den Code zu verstehen, vielleicht finde ich die Lösung selbst. Auf jeden Fall schon mal vielen Dank

viele Grüße

Richard

Answer 6

Hallo Richard,

bei meiner Testdatei hat das Makro problemlos funktioniert. Falls du nicht weiterkommst, dann kannst du eine Beispieldatei mal hochladen, z.B. hier, und den Link dann posten.

Gruß

M.O.