xls-Datei aufteilen in Einzeldateien
Hei.Fisch
ich habe hier ein kleines VBA-Programm, mit dem ich bestimmte Zeilen aus einer großen Tabelle in einzelne Tabellenblätter kopieren kann.
Nun brauche ich im Prinzip genau dasselbe, nur sollen die Daten nicht in ein neues Blatt, sondern in eine neue Arbeitsmappe kopiert werden. Diese soll im gleichen Ordner erzeugt und gespeichert werden.
Ganz toll wäre es, wenn ich den neuen Dateien auch gleich noch ein Passwort zuordnen könnte.
Hintergrund ist: Das Warenwirtschaftssystem spuckt eine sehr große Tabelle mit Kundendaten aus, die jedoch den 18 Kundenberatern einzeln zur Verfügung gestellt werden sollen.
Das bisherige Programm arbeitet folgendermaßen:
Die Prozedur "Test" kopiert mit Hilfe der Prozedur "CopyWithValues" alle Zeilen des aktiven Worksheets, die als Wert "YOURVALUE" in der Spalte "F" als Text haben (damit sind auch Personalnummern als String interpretiert), in das Worksheet mit dem Namen "Sheet2". (Bei YOURVALUE kann der Name des Kundenberaters eingetragen werden).
Im Anhang ein kleines, abgespecktes Beispiel: https://www.herber.de/bbs/user/69744.xls
Bitte das Makro KB_vereinzeln starten, dann wird gleich alles klar.
Wie muss ich den bestehenden Quellcode abändern, um aus CopyWithValues ein neues SaveWithValues zu bekommen?
CopyWithValues tut folgendes:
- Es versucht ein Worksheet zu finden, dass den angegebenen Namen enthält.
- Gibt es ein solches nicht, dann wird ein neues angelegt und die Werte werden kopiert.
- Danach springt die Prozedur wieder zum Ausgangssheet zurück, so dass die Prozedur mit einem _ neuen Satz Parameter aufgerufen werden kann.
Private Sub CopyWithValues(testValue As String, column As String, sheetName As String)
Dim rootSheet As Object
Dim newSheet As Object
Dim workRange As Range
Dim destinationRange As Range
Dim currentRow As Range
Dim strValue As String
Dim counter As Integer
Dim row As String
counter = 1
Set rootSheet = ActiveSheet
Set workRange = rootSheet.UsedRange
On Error GoTo CREATESHEET
Set newSheet = ActiveWorkbook.Sheets(sheetName)
GoTo ACTIVATESHEET
CREATESHEET:
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = sheetName
Set newSheet = ActiveSheet
ACTIVATESHEET:
newSheet.Activate
For Each currentRow In workRange.Rows
strValue = CStr(currentRow.Range(column & 1).Text)
If strValue = testValue Then
Set destinationRange = ActiveWorkbook.Sheets(sheetName).Rows(counter & ":" & counter)
currentRow.Copy destinationRange
counter = counter + 1
End If
Next
rootSheet.Activate
End Sub