Hallo Niclaus,
also wie gesagt, das Makro funktioniert, wenn die Urliste (also die ich per Mail erhalte) in der gleichen Arbeitsmappe ist, wie das Makro läuft.
Das Makro wird durch einen Button in einer Userform gestartet.
Folgende Infos vorab:
In der ComboBox1 und zwei sind die Spaltenüberschriften drin (füllen sich beim Start).
Die Eingabe (vorgabe vorhanden) txtBox2 wird in G1 geschrieben
Die EIngabe (vorgabe vorhanden) txtBox1 wird zur Ermittlung der Größe (Anzahl der Zeilen) der „neuen“ Listen genutzt. (vorgabe 25)
Hier nun das Makro:
Public Sub CommandButton1_Click()
Dim dubletten As String
Dim sortieren As String
Dim spdublett As Variant
Dim spsortier As Variant
Dim letztezeile As Integer
Dim aktzeile As Integer
Dim Mappennummer As Integer
Dim maximal As Integer
Dim laenge As Integer
Dim sp As Integer
Dim dublettenanz As Integer
Dim zeilenalt As Integer
Dim weite As Long
Dim pfad As String
Dim zVon As Long, zBis As Long, letzte As Long
spdublett = 1
spsortier = 1
On Error GoTo Errorhandler
'Auslesen der Userform
’
ActiveSheet.Range(„G1“) = txtBox2
dubletten = UserForm1.ComboBox1.Value
sortieren = UserForm1.ComboBox2.Value
laenge = UserForm1.txtBox1.Value
'prüfen ob „laenge“ einen gültigen Wert enthält
’
If laenge < 1 Then
MsgBox „Bitte die Größe der Listen eingeben“, vbOKOnly
GoTo ausgang
End If
'prüfen ob Dubletten und Sortierung angegeben wurden
’
If dubletten = „“ Then
dubletten = „keine Dublettensuche“
spdublett = 1
If sortieren = „“ Then
sortieren = „keine Sortierung“
spsortier = 1
MsgBox "Sortierung: " & sortieren & ". ; Dublettensuche: " & dubletten & ".", vbCritical
GoTo weiter
'Spalte wo Dubletten entfernt werden sollen
’
Do Until ActiveCell = dubletten
spdublett = spdublett + 1
ActiveSheet.Cells(1, spdublett).Activate
Loop
’ Herausfinden der letzten Zeile
’
Range(„A:E“).Select
letztezeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
zeilenalt = letztezeile
'Dubletten entfernen
’
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
ActiveSheet.Range("$A$2:$E$" & letztezeile).RemoveDuplicates Columns:=spdublett, Header:=xlNo
’ Herausfinden der letzten Zeile
’
letztezeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Info wieviele Dubletten entfernt wurden
’
dublettenanz = zeilenalt - letztezeile
MsgBox „Es wurden " & dublettenanz & " Dubletten bei " & dubletten & " gefunden und entfernt.“, vbOKOnly + vbCritical, „Dubletten entfernt“
sort:
'Spalte die sortiert werden soll
’
Do Until ActiveCell = sortieren
spsortier = spsortier + 1
ActiveSheet.Cells(1, spsortier).Activate
Loop
'Sortierung
’
Columns(„A:E“).Select
ActiveSheet.sort.SortFields.Clear
ActiveSheet.sort.SortFields.Add Key:=Range(Cells(2, spsortier), Cells(letztezeile, spsortier)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.sort
.SetRange Range(„A1:E“ & letztezeile)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
weiter:
Columns(„A:E“).EntireColumn.AutoFit
'Einteilung der Liste
’
aktzeile = 2
Mappennummer = 1
maximal = (letztezeile - 1) / laenge
If maximal > Int(maximal) + 0.5 Then maximal = maximal + 1
Do
Range(„A“ & aktzeile) = Mappennummer
aktzeile = aktzeile + laenge
Mappennummer = Mappennummer + 1
Loop Until Mappennummer > maximal
MsgBox „Es werden " & maximal & " Listen erzeugt“, vbOKOnly
'Listen stückeln
’ Pfad erfragen
’
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = „Wohin sollen die Teil-Listen gespeichert weden?“
.InitialView = msoFileDialogViewDetails
.InitialFileName = „C:“
weite = .Show
If weite = 0 Then Exit Sub
pfad = .SelectedItems(1) & „“
End With
With Tabelle1
zVon = 2
letzte = .Cells(.Rows.Count, 2).End(xlUp).Row
'Schleife zum Speichern der Listen
’
Do
zBis = WorksheetFunction.Min(.Cells(zVon, 1).End(xlDown).Row - 1, letzte)
'neue Mappe erstellen
’
Workbooks.Add
'Überschriften
’
Range(„B1“) = „Auftragsnummer“
Range(„C1“) = „Kunde“
Range(„D1“) = „Unternehmes-ID“
Range(„E1“) = „Geschäftsjahr bis“
Range(„F1“) = „Ergebnis“
'Ergebnisliste erstellen
’
Range(„K3“) = „war bereits angepasst“
Range(„K4“) = „neu angepasst“
Range(„K5“) = „ohne RN gelöscht“
Range(„K6“) = „Insolvenz“
Range(„K7“) = „erweiterte Recherche“
’ Spalte „K“ ausblenden
’
Columns(„K:K“).Hidden = True
’ Dropdownmenue erstellen (Ergebnis)
’
With Range(„F2“)
With .Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$K$3:$K$8"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = „“
.ErrorTitle = „“
.InputMessage = „Ergebnis“
.ErrorMessage = „“
.ShowInput = True
.ShowError = True
End With
.Copy Destination:=Range(„F3:F“ & zBis - zVon + 2)
End With
’ entsprechende Zeilen in die neue Mappe einfügen
’
.Range(„A“ & zVon & „:E“ & zBis).Copy Destination:=Range(„A2“)
Columns("A:F").EntireColumn.AutoFit
’ bedingte Formatierung für den Status hinzufügen
’
ActiveSheet.Range(„F2:F38“).Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="="„erweiterte Recherche“""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="="„ohne RN gelöscht“""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""erweiterte Recherche"",""Grund:"","""")"
Range("G2").Select
Selection.Copy
Range("G3:G38").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("F:F").ColumnWidth = 20
Range("F2").Select
’ Als neue Mappe speichern
’
ActiveWorkbook.SaveAs filename:=pfad & Range(„A2“) & Range(„G1“) & „.xlsx“
ActiveWorkbook.Close
zVon = zBis + 1
Loop Until zBis = letzte
End With
GoTo ausgang
'Errorhandling
Errorhandler:
MsgBox „Fehler in Sub Fehler:“ & vbCrLf & "Fehlernummer: " & Err.Number & vbCrLf & "Fehlerbeschreibung: " & Err.Description
'Ausgang
’
ausgang:
Unload UserForm1
End Sub
Hoffe das mein Programmierstil nicht zu chaotisch ist! 
Danke schonmal und Liebe Grüße
René
