AW: Makro soll eigenständig Dateien erstelle
13.10.2020 12:34:41
Nepumuk
Hallo Silvio,
teste jetzt mal:
Option Explicit
Public Sub CreateWorkbooks()
Dim objFileDialog As FileDialog
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
Dim objDicionary As Object
Dim strFolder As String
Dim vntItem As Variant, avntValues As Variant
Set objFileDialog = Application.FileDialog(fileDialogType:=msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = "H:\" ' Anpasssen
If .Show Then strFolder = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If strFolder <> vbNullString Then
Application.ScreenUpdating = False
If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
Set objWorksheet = ThisWorkbook.Worksheets("Tabelle1") ' Anpassen !!!
With objWorksheet
avntValues = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value2
End With
Set objDicionary = CreateObject(Class:="Scripting.Dictionary")
For Each vntItem In avntValues
objDicionary.Item(Key:=vntItem) = vbNullString
Next
For Each vntItem In objDicionary.Keys
Call objWorksheet.Rows(1).AutoFilter(Field:=2, Criteria1:=vntItem)
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
Call objWorksheet.AutoFilter.Range.Copy(Destination:=objWorkbook.Worksheets(1).Cells(1, 1))
Call objWorkbook.SaveAs(Filename:=strFolder & vntItem & _
" 2020-10-12.xlsx", FileFormat:=xlOpenXMLWorkbook)
Call objWorkbook.Close
Next
Call objWorksheet.Rows(1).AutoFilter
Set objWorkbook = Nothing
Set objDicionary = Nothing
Set objWorksheet = Nothing
Application.ScreenUpdating = True
End If
End Sub
Gruß
Nepumuk