Microsoft Excel

Herbers Excel/VBA-Archiv

Makro soll eigenständig Dateien erstelle

Betrifft: Makro soll eigenständig Dateien erstelle von: Silvio
Geschrieben am: 12.10.2020 16:10:27

Hallo Zusammen,


ich stehe vor einer großen Aufgabe, die ich bestimmt durch ein Makro etwas erleichtern kann.


Und zwar muss ich meine Arbeitsmappe aufteilen.. Hierfür steht in Spalte B immer ein eindeutiger Name zum erkennen. Dieser geht über viele Zeilen hinweg. Die Aufgabe liegt darin, alle Zeilen die in Spalte B den selben Namen haben in einer neuen Excel Datei abzuspeichern und das für alle Namen.

Wenn es dann noch möglich ist, diese neue Excel direkt mit dem Namen aus Spalte B zu benennen und einem kleinen Zusatz (2020-10-12), wäre das schon perfekt. Zum Schluss müsste ich noch den richtigen Ordner zum abspeichern angeben können.


Leider belaufen sich meine VBA bzw. Makro Kenntnisse gegen 0 :(

Ich bitte vielmals um eure Hilfe :)

Vielen Dank


Silvio

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Nepumuk
Geschrieben am: 12.10.2020 16:56:20

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

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Silvio
Geschrieben am: 13.10.2020 09:24:04

Hallo Nepumuk,

leider hat das nicht so ganz geklappt.
Es wird nur eine neue Datei erstellt die den Namen vom ersten Account trägt aber kein Inhalt drinnen ist. Also es wird aus der Stammdatei nicht der Inhalt der einzelnen Zeilen in die neue Datei übertragen.
Wie löse ich es, dass die ganz Datei durchläuft.

Vielen dank schonmal

Silvio

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Nepumuk
Geschrieben am: 13.10.2020 10:29:24

Hallo Silvio,

dann musst du das genau beschreiben wie die Mappe aufgeteilt werden soll. In deine ersten Anfrage finde ich nichts davon.

Gruß
Nepumuk

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Silvio
Geschrieben am: 13.10.2020 11:57:44

Hi Nepomuk,

ich hab jetzt mal eine abgespeckte Datei erstellt.
- In der echten Datei lässt sich eindeutig durch die Spalte B Organisation sortieren
- Man sieht das die Organisation A von Zeile 1 bis 136 geht und diese Zeilen sollen jetzt kopiert werden und in einer neuen Datei mit dem Namen der Organisation und dem Zusatz (2020-10-12) gespeichert werden.
- Dies soll jetzt in dem Beispiel für alle Organisationen (von A-C) durchgelaufen werden und jede mit den Informationen in einer separaten Datei gespeichert werden.

Ich hoffe damit kannst du mehr anfangen?
Vielen vielen Dank für deine Hilfe

Silvio

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Nepumuk
Geschrieben am: 13.10.2020 12:03:43

Hallo Silvio,

und wo ist die Datei? Du musst, nach dem Hochladen, den Link kopieren und in den Beitragstext einfügen.

Gruß
Nepumuk

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Silvio
Geschrieben am: 13.10.2020 12:11:11

https://www.herber.de/bbs/user/140857.xlsx

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Nepumuk
Geschrieben am: 13.10.2020 12:34:41

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

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Silvio
Geschrieben am: 13.10.2020 14:01:03

Hallo Nepumuk,

erstmal vielen dank. Kannst du mir noch dabei helfen, was genau ich an den zwei Stellen anpassen muss?

Silvio

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Nepumuk
Geschrieben am: 13.10.2020 14:32:08

Hallo Silvio,

beim 1. kannst du ein Verzeichnis oder ein Laufwerk vorgeben. Beim 2. musst du den Namen der Ursprungstabelle eintragen, das war in deiner Mustermappe "Tabelle1".

Gruß
Nepumuk

Betrifft: AW: Makro soll eigenständig Dateien erstelle
von: Silvio
Geschrieben am: 13.10.2020 14:57:56

Hallo Nepumuk,

vielen vielen Dank!! Es hat alles genau so funktioniert wie es sollte :)
Schönen Tag noch

Mit ganz lieben Grüßen
Silvio

Betrifft: Crossposting
von: SF
Geschrieben am: 13.10.2020 09:30:10

https://www.clever-excel-forum.de/Thread-Makro-soll-eigenstaendig-Dateien-erstelle

Betrifft: AW: Crossposting
von: Silvio
Geschrieben am: 13.10.2020 09:48:04

Vielen Dank für die den Link, bringt nur leider nichts :/

Betrifft: AW: Crossposting
von: SF
Geschrieben am: 13.10.2020 15:20:20

Doch, den Helfern. Die können nämlich gucken ob es schon irgendwo anders Antworten gibt!
Ansonsten könnte es zu unnötiger Doppelarbeit kommen.
Arbeitest du gerne umsonst?