Excel-Datei automatisch splitten

Forumthread: Excel-Datei automatisch splitten

Klaus

Hallo zusammen,
ich bin sehr auf Eure Hilfe angewiesen.
Meine Exceldatei besteht aus sehr vielen Zeilen und mehreren Spalten.
Gibt es eine Möglichkeit, dass Excel bei jeder Änderung eines Wertes (zB in Spalte A) die entsprechenden Zeilen in eine eXtra Datei kopiert?
Bsp - 3 Spalten:
120 55 Jahre M
120 41 Jahre W
120 40 Jahre W
200 34 Jahre M
800 62 Jahre M
800 20 Jahre W
Excel soll die Dateien in mehrere Dateien (oder zumindest in Tabellenblätter) aufsplitten, sodass:
3 Dateien die jeweils alle Daten für Spalte A mit (120), (200) und (800) separat kopiert.
Vielleicht geht das mit VBA?
Für Tipps bin ich euch 1000 Mal dankbar! :)
Grüße
Klaus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: Excel-Datei automatisch splitten

05.08.2009 14:38:49

Wolli

Hallo Klaus,
so müsste es gehen:

Sub splitten()
Dim shBlatt As Worksheet, lngZeile As Long
Do
lngZeile = 1
Set shBlatt = ActiveSheet
Do
lngZeile = lngZeile + 1
If shBlatt.Cells(lngZeile, 1) = "" Then Exit Sub
Loop Until shBlatt.Cells(lngZeile, 1)  Cells(lngZeile - 1, 1)
Range(shBlatt.Cells(lngZeile, 1), shBlatt.Cells(shBlatt.UsedRange.Rows.Count, _
shBlatt.UsedRange.Columns.Count)).Cut
Set shBlatt = ActiveWorkbook.Sheets.Add(after:=shBlatt)
shBlatt.Paste
Application.CutCopyMode = False
Loop
End Sub

Dieses Tool legt bei jedem Wechsel in Spalte A ein neues Blatt an und kopiert die nachstehenden Daten da hinein.
Gruß, Wolli

AW: Excel-Datei automatisch splitten

05.08.2009 14:47:52

Klaus

Danke Wolli,
du hast es echt drauf!!
Gibts das auch, dass Excel gesonderte Dateien erstellt?
Danke und Gruß

Bitte sehr!

05.08.2009 15:17:41

Wolli


Sub splitten2()
Dim wbMappe As Workbook, shBlatt As Worksheet, lngZeile As Long
Set shBlatt = ActiveSheet
Do
lngZeile = 1
Do
lngZeile = lngZeile + 1
If shBlatt.Cells(lngZeile, 1) = "" Then Exit Sub
Loop Until shBlatt.Cells(lngZeile, 1)  Cells(lngZeile - 1, 1)
Range(shBlatt.Cells(lngZeile, 1), shBlatt.Cells(shBlatt.UsedRange.Rows.Count, _
shBlatt.UsedRange.Columns.Count)).Cut
Set wbMappe = Workbooks.Add
Set shBlatt = wbMappe.Sheets(1)
wbMappe.Sheets(1).Paste
Application.CutCopyMode = False
Loop
End Sub

Die Mappe stehen dann aber unbenannt und offen in der Gegend rum und müssen noch gespeichert werden. Könnte man auch automatisieren - dann müsstest Du sagen, unter welchem Namen (z.B. mit Hilfe von Zelle A1 zusammenbasteln) und an welchen Ort!
Gruß, Wolli

AW: Bitte sehr!

05.08.2009 15:40:44

Klaus

Hi Wolli,
ein sehr sehr großes Dankeschön an dich! Du hast mir sehr viel Arbeit erspart =)
Wenn du mir jetzt noch sagst wie das funktioniert, dass jede Datei unter dem jeweiligen Namen der Spalte A gespeichert wird an Speicherort X..., dann bist du der Excel King :D
Viele Grüße
:D

Nochmal Bitte sehr!

05.08.2009 16:29:00

Wolli

Hallo Klaus, ich hatte gehofft, dass Du das nicht willst, denn es ist etwas fummelig. :-)) Müsste aber gehen wie gewünscht. Passe bitte noch den Pfad an. Die Dateien werden dort hineingespeichert und geschlossen.
Gruß, Wolli

Sub splitten()
Dim wbMappe As Workbook, _
wbMappeAlt As Workbook, _
shBlatt As Worksheet, _
lngZeile As Long, _
strPfad As String
'Pfad festlegen (mit "\")
strPfad = "C:\Temp\"
'Erstmal alles in eine neue Mappe schaufeln
ActiveSheet.UsedRange.Cut
Set wbMappe = Workbooks.Add
wbMappe.Sheets(1).Paste
Application.CutCopyMode = False
Set shBlatt = ActiveSheet
Do
'falls vorhanden, die letzte Mappe speichern + schließen
If Not wbMappeAlt Is Nothing Then
wbMappeAlt.SaveAs Filename:=strPfad & _
CStr(wbMappeAlt.Sheets(1).Cells(1, 1).Value) & ".xls"
wbMappeAlt.Close
Set wbMappeAlt = Nothing
End If
'nächsten Bruch suchen
lngZeile = 1
Do
lngZeile = lngZeile + 1
'wenn Ende, dann Ende
If shBlatt.Cells(lngZeile, 1) = "" Then Exit Do
Loop Until shBlatt.Cells(lngZeile, 1)  Cells(lngZeile - 1, 1)
'wenn Ende, dann Ende
If shBlatt.Cells(lngZeile, 1) = "" Then Exit Do
'Rest ausschneiden und in neue Mappe verschieben
Range(shBlatt.Cells(lngZeile, 1), shBlatt.Cells(shBlatt.UsedRange.Rows.Count, _
shBlatt.UsedRange.Columns.Count)).Cut
Set wbMappeAlt = ActiveWorkbook 'Alte Mappe markieren
Set wbMappe = Workbooks.Add
Set shBlatt = wbMappe.Sheets(1)
wbMappe.Sheets(1).Paste
Application.CutCopyMode = False
Loop
'Am Ende die Aktive Mappe speichern und schließen.
ActiveWorkbook.SaveAs Filename:=strPfad & _
CStr(ActiveWorkbook.Sheets(1).Cells(1, 1).Value) & ".xls"
ActiveWorkbook.Close
End Sub

AW: Nochmal Bitte sehr!

05.08.2009 16:40:04

Klaus

You are the GODFATHER of excel! =)
Falls ich damit noch Probleme hab, werd ich nicht zögern, dich nochmals kurz zu nerven!! :)
Danke vielmals! (!!)
VIELE GRÜßE!

AW: Excel-Datei automatisch splitten

07.08.2009 10:44:52

Klaus

Hallo Wolli,
bin schon sehr weit gekommen mit deinem Makro.. Noch kurz eine Frage: Gibt es eine Möglichkeit bei dem Dateisplit, dass die erste Zeile in jede neue Datei übernommen wird. Diese soll nämlich in jeder Datei als Überschrift dienen?
Vielen Dank im Voraus
Klaus

So in etwa?

07.08.2009 12:43:59

Wolli


Sub splitten()
Dim wbMappe As Workbook, _
wbMappeAlt As Workbook, _
lngZeile As Long, _
strPfad As String
'Pfad festlegen (mit "\")
strPfad = "C:\Temp\"
'Erstmal alles in eine neue Mappe schaufeln
ActiveSheet.UsedRange.Cut
Set wbMappe = Workbooks.Add
wbMappe.Sheets(1).Paste
Application.CutCopyMode = False
Do
'falls vorhanden, die letzte Mappe speichern + schließen
If Not wbMappeAlt Is Nothing Then
wbMappeAlt.SaveAs Filename:=strPfad & _
CStr(wbMappeAlt.Sheets(1).Cells(2, 1).Value) & ".xls"
wbMappeAlt.Close
Set wbMappeAlt = Nothing
End If
'nächsten Bruch suchen
lngZeile = 2 'wegen der Überschriften in Z. 2 beginnen!
Do
lngZeile = lngZeile + 1
'wenn Ende, dann Ende
If Cells(lngZeile, 1) = "" Then Exit Do
Loop Until Cells(lngZeile, 1)  Cells(lngZeile - 1, 1)
'wenn Ende, dann Ende
If Cells(lngZeile, 1) = "" Then Exit Do
'Rest ausschneiden und in neue Mappe verschieben
Range(Cells(lngZeile, 1), Cells(ActiveSheet.UsedRange.Rows.Count, _
ActiveSheet.UsedRange.Columns.Count)).Cut
Set wbMappeAlt = ActiveWorkbook 'Alte Mappe merken
Set wbMappe = Workbooks.Add
Application.Goto wbMappe.Sheets(1).Cells(2, 1)
ActiveSheet.Paste
wbMappeAlt.Sheets(1).Rows(1).Copy Destination:=ActiveSheet.Rows(1)
Application.CutCopyMode = False
Loop
'Am Ende die Aktive Mappe speichern und schließen.
ActiveWorkbook.SaveAs Filename:=strPfad & _
CStr(ActiveWorkbook.Sheets(1).Cells(2, 1).Value) & ".xls"
ActiveWorkbook.Close
End Sub

Ich habe auch sonst noch ein wenig herumoptimiert.
Gruß und schönes WE, Wolli

Beliebteste Forumthreads (12 Monate)

Forumthread: Excel-Datei automatisch splitten

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread