Daten Spalte B jeweils in neue Dateien aufteilen!

Frage aus Office-Loesung: Werte aus Spalte B die jeweils ein- oder auch mehrmals unsortiert vorliegen, sollen in neue Dateien abgespeichert werden. Im folgenden Beispiel von Spalte A bis Spalte D. Gelöst über temporäre Tabellenblätter und den Spezialfilter. Eventuell vorhandene Dateien mit gleichem Namen werden ohne Nachfrage überschrieben.

Daten Spalte B jeweils in neue Dateien aufteilen...[ZIP, 50 KB]

Option Explicit
Public Sub Aufteilen()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wkbBook As Workbook
Dim lngLastRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' Tabellenblatt mit Daten - Name ANPASSEN
Set wksQuellSheet = Worksheets("Gesamt")
Set wksKriterienSheet = Worksheets.Add
wksKriterienSheet.Move After:= _
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
lngLastRow = wksQuellSheet.Range("B" & Rows.Count).End(xlUp).Row
wksQuellSheet.Range("B1:B" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
Set rngKriterium = wksKriterienSheet.Range("A2")
While rngKriterium.Value <> ""
Set wksNew = Worksheets.Add
wksQuellSheet.Range("A1:D" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1"), Unique:=True
wksNew.Name = rngKriterium.Text
rngKriterium.EntireRow.Delete
wksNew.Copy
Set wkbBook = ActiveWorkbook
If Val(Application.Version) < 12 Then
wkbBook.SaveAs ThisWorkbook.Path & _
"\" & wksNew.Name & ".xls"
Else
wkbBook.SaveAs ThisWorkbook.Path & _
"\" & wksNew.Name, 56
End If
wkbBook.Close SaveChanges:=False
Set wkbBook = Nothing
wksNew.Delete
Set wksNew = Nothing
Set rngKriterium = Nothing
Set rngKriterium = wksKriterienSheet.Range("A2")
Wend
wksKriterienSheet.Delete
Set wksKriterienSheet = Nothing
Fin:
If Not wksNew Is Nothing Then _
wksNew.Delete
If Not wksKriterienSheet Is Nothing Then _
wksKriterienSheet.Delete
With Application
.Goto wksQuellSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set wkbBook = Nothing
Set wksKriterienSheet = Nothing
Set wksQuellSheet = Nothing
Set rngKriterium = Nothing
Set wksNew = Nothing
End Sub

Kommentare

Kommentar veröffentlichen

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...