Sheet generieren und speichern

Hallo Excelfreunde,
ich habe folgendes Problem, welches ich nicht gelöst bekomme:
Ich habe eine Exceldatei mit 2 Sheets. Auf dem ersten Sheet stehen die Daten und auf dem 2. Sheet eine Tabelle mit Kostenstellen.
Ich habe ein Makro, welches Anhand der Kostenstellen für jede vorhandene Kostenstelle ein Sheet generiert. Das Sheet bekommt auch den Namen der Kostenstelle. Auf die generierten Sheets möchte ich einen fixen Bereich vom Sheet 1 kopieren. Es handelt sich um den Bereich A1:N7. Anschließend sollen die Daten entsprechend der Kostenstellen gefiltert und auf die dazugehörigen Sheets ab Zelle A8 kopiert werden.
Danach soll jedes vorhandenen Sheets in eine einzelne Datei innerhalb eines bestimmten Pfades gespeichert werden.
Ich hoffe Ihr habt eine Lösung für mich und bedanke mich jetzt schon für Eure Hilfe.
Viele Grüße Achim

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
so....

Option Explicit 
Sub CreateSheets() 
    Dim Zelle, Bereich As Range 
    Dim i As Integer, LR As Double 
    Dim nWS As Worksheet 
    Dim Bool As Boolean 
    Dim Pfad As String, Datei As String 
     
    Pfad = "C:\Temp\" 
    LR = Worksheets("Kostenstellen").Cells(Rows.Count, 1).End(xlUp).Row 
    Set Bereich = Worksheets("Kostenstellen").Range("A3:A" & LR) 
    For Each Zelle In Bereich 
     
        For i = 2 To Worksheets.Count 
            If Worksheets(i).Name = Zelle.Value Then 
                Bool = True 
                Exit For 
            Else 
                Bool = False 
            End If 
        Next i 
         
        If Bool = False Then 
            Set nWS = Worksheets.Add(after:=Worksheets(Worksheets.Count)) 
            nWS.Name = Zelle.Value 
            Datei = Zelle.Value & ".xlsx" 
            With Sheets("Master") 
                LR = .Cells(Rows.Count, 1).End(xlUp).Row 
                .Range("A1:N7").Copy nWS.Range("A1") 
                .Range("$A$7:$N$" & LR).AutoFilter Field:=3, Criteria1:=nWS.Name 
                .Rows("8:" & LR).Copy nWS.Range("A8") 
                .ShowAllData ' Autofilter alle 
                nWS.Move 
                ActiveWorkbook.SaveAs Filename:=Pfad & Datei, FileFormat:= _
                    xlOpenXMLWorkbook 
                ActiveWorkbook.Close 
            End With 
        End If 
    Next Zelle 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Gruß UweD

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread