Makro soll eigenständig Dateien erstelle

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Silvio,
teste mal:

Option Explicit

Public Sub CreateWorkbooks()
    Dim objFileDialog As FileDialog
    Dim objWorkbook As Workbook
    Dim strFolder As String
    Dim vntItem 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
        For Each vntItem In Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp)).Value2
            Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
            Call objWorkbook.SaveAs(Filename:=strFolder & vntItem & _
                " 2020-10-12.xlsx", FileFormat:=xlOpenXMLWorkbook)
            Call objWorkbook.Close
        Next
        Set objWorkbook = Nothing
        Application.ScreenUpdating = True
    End If
End Sub

Gruß
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

Beliebteste Forumthreads (12 Monate)

Makro soll eigenständig Dateien erstelle

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread