AW: OK, ging wirklich nicht ....
06.12.2012 11:59:10
Klaus
Hi,
probier mal den.
Anmerkung: Das Ursprungsblatt muss sortiert sein!
also zum Beispiel das:
ABCD_1 - EFGH_1
ABCD_1 - EFGH_1
ABCD_1 - EFGH_2
ABCD_1 - EFGH_2
ABCD_1 - EFGH_1 (GAB SCHONMAL WEITER OBEN)
darf nicht passieren, sonst gibts nen Error!
Anmerkung zwei:
im Zweifelsfall funktioniert das:
Sheets("Tabelle1").Delete
Sheets("Tabelle2").Delete
Sheets("Tabelle3").Delete
nicht wie es soll. Ich hab englisches Exel, bei mir muss es heissen Sheets("Sheet1").delete Ich bin mir ziemlich, aber nicht 100% ig, sicher dass es im deutschen Excel "Tabelle1" heisst. Ausserdem weiss ich ja nicht, ob du überhaupt ein deutsches Excel hast :-)
Anmerkung 3: (für stille Mitleser, nicht für dich)
ja, ich lösche Datensätze aus einer laufenden Schleife und frage dann den neuen Inhalt auf "" ab. Mit ist bewusst dass das nicht ganz sauber ist und ab ein paar millionen Datensätzen auch zu unnötigen Performanceeinbrüchen führt. Hier solls reichen, und es ist recht einfach zu programmieren und hoffentlich auch einfach nachzuvollziehen. Meiner Meinung nach ist ein nachvollziehbarer Code eine bessere Hilfe als ein bis-ins-letzte optimierter Ablauf, den der Neuling gar nicht verstehen kann - und ja, ich war zu faul das optimal zu schreiben :-)
Grüße,
Klaus M.vdT.
Option Explicit
Sub SaveManyFiles()
Dim icol As Integer
Dim iColTable As Integer
Dim wksOld As Worksheet
Dim sPath As String
'Umbenennen! Wird bei dir ja nicht "Tabelle1" heissen
Set wksOld = Sheets("Tabelle1")
'Hier die SPALTE angeben in der die nächsten Dateinamen stehen! A = 1, B = 2
icol = 1
'und hier die SPALTE, in der die Tabellennamen stehen!
iColTable = 2
'Hier werden die neuen Dateien gespeichert
sPath = "C:\TestTMP"
'Hier fängt der Code an!
Dim rDatei As Range
Dim lRowLast As Long
Dim lAnzDatei As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim iColLast As Integer
With wksOld
lRowLast = .Cells(Rows.Count, icol).End(xlUp).Row
'letzte Zeile
iColLast = .UsedRange.Columns.Count
'Anzahl Spalten
For Each rDatei In Range(Cells(2, icol), Cells(lRowLast, icol))
'für den Bereich
lAnzDatei = Application.WorksheetFunction.CountIf(.Cells(1, icol).EntireColumn, _
rDatei.Value) 'so viele Datensätze dieses Names gibt es
If rDatei = "" Then _
'wenn leer dann nix! (Leer wenn gelöscht, siehe unten)
Else
Set wkbOld = ActiveWorkbook
'diese Datei merken
rDatei.Resize(lAnzDatei, iColLast).Copy
'gesamte Zeile kopieren
Workbooks.Add
'neues Excelsheet
Set wkbNew = ActiveWorkbook
'Focus liegt automatisch auf neuer Datei! Darum klappt "activeworkbook" nochmal
Range("A1").PasteSpecial
'einfügen
Call MakeManyTables(iColTable)
'hier wird das Makro aufgerufen, dass die Unteraufgabe erfüllt
wkbNew.SaveAs Filename:=sPath & "\" & rDatei.Value & ".xls", FileFormat:= _
xlExcel8
'neue Datei speichern als *.xls
wkbNew.Close
'neue Datei schließen
rDatei.Resize(lAnzDatei, 1).EntireRow.ClearContents
'Datensatz aus alter Datei entfernen
End If
Next rDatei
End With
End Sub
Sub MakeManyTables(iColNew As Integer)
Dim lRow As Long
Dim lAnzTable As Long
Dim wksOld As Worksheet
Set wksOld = ActiveSheet 'Blatt merken
Dim rTables As Range
lRow = Cells(Rows.Count, iColNew).End(xlUp).Row 'letzte Zeile
For Each rTables In Range(Cells(1, iColNew), Cells(lRow, iColNew))
If rTables.Value = "" Then
'nix! wenn leer dann nix!
Else 'aber sonst!
lAnzTable = Application.WorksheetFunction.CountIf(Cells(1, iColNew).EntireColumn, _
rTables.Value)
'so viele Datensätze dieses Names gibt es
Cells(rTables.Row, 1).Resize(lAnzTable, Columns.Count).Copy 'kopieren
Sheets.Add 'neues sheet
With ActiveSheet 'das neu erstellte sheet ist automatisch "active"!
.Name = rTables.Value 'sheet umbenennen
.Range("A2").PasteSpecial
.Range("A1").Value = "Überschrift 1" 'Überschriften wirst du brauchen?
.Range("B1").Value = "Überschrift 2" 'ändere sie hier!
.Range("C1").Value = "Überschrift 3" 'wenns mehr als vier Spalten werden,
.Range("D1").Value = "Überschrift 4" 'einfach fortsetzen bis der Artzt kommt. _
End With
wksOld.Activate 'zurück zum alten Blatt
Cells(rTables.Row, 1).Resize(lAnzTable, Columns.Count).ClearContents 'alten _
Datensatz löschen
End If
Next rTables
'* Dieser Block löscht die nun nicht mehr benötigten Tabellen 1, 2 und 3.
'* Das "DisplayAlerts" wird abgeschaltet, um das Fenster vom Excel
'* "da kann aber was in der Tabelle sein! Echt löschen?" zu verhindern
Application.DisplayAlerts = False
Sheets("Tabelle1").Delete
Sheets("Tabelle2").Delete
Sheets("Tabelle3").Delete
Application.DisplayAlerts = True
'* Block Tabellenlöschen Ende
End Sub