Hallo alle Zusammen,

Ich habe aktuell ein Projekt, in dem ich eine Tabelle in ein neues Arbeitsblatt kopiere und exportieren möchte als eigene Excel-Datei.

Ich habe auch schon ein Code geschrieben, welcher aber die komplette Arbeitsmappe, in der das Makro läuft, speichert. Hat jemand eine Lösung?

Option Explicit

Sub anlagenEinzelnExcel()

'---Spalten mit RG-Nummer-Einträgen zählen---

Dim RG_Nr As Integer
Dim countRow As Double
Dim i As Double
Dim cellnumeric As Boolean
Dim RG_Column As Long ' Spalte, in der die RG Nummer steht
Dim rgWs As Worksheet
Set rgWs = ThisWorkbook.Worksheets("RG-Anlage")
Dim Blatt As Worksheet

For Each Blatt In ThisWorkbook.Worksheets
    If Blatt.Name = "AnlagenTab" Then
        GoTo Weiter
    End If
Next Blatt

Weiter:
Worksheets("RG-Anlage").Activate

i = 7
countRow = 7
RG_Column = Range(ActiveSheet.PageSetup.PrintArea).Columns.Count + 2
Cells(countRow, RG_Column).Activate


Do Until ActiveCell.Value = 0
    Cells(countRow, RG_Column).Activate
    RG_Nr = ActiveCell.Value
    countRow = countRow + 1
Loop

countRow = countRow - 8

'---Anlagen trennen durch RG-Nummern und exportieren auf Word-Datei---

Dim currentColumn As Double 'enthält die aktuelle SpaltenANzahl
Dim pastColumnValue As Integer 'Enthält den vorigen Spaltenwert, wird verwendet um Druckbereich festzulegen
Dim countRange As Integer 'gibt die Spaltenanzahl der Anlage mit der aktuellen RG-Nummer an
Dim aktuelleSpaltenZahl As Integer 'Enthält die Spaltenanzahl, die aktuell zu markieren/drucken ist
Dim j As Double 'Zählervariable für Schleife
Dim strPrintArea As String 'String mit dem Druckbereich
Dim druckZeile As String 'Zeile der Anlage, ab der gedruckt werden soll

countRange = 0
currentColumn = 7
Cells(currentColumn, RG_Column).Activate
RG_Nr = ActiveCell.Value

'Druck-Schleife
For j = 0 To countRow - 1
    Worksheets("RG-Anlage").Activate
    Worksheets("RG-Anlage").Cells(currentColumn, RG_Column).Activate 'Zeigt aktuell angewählte Zelle an
    
    If ActiveCell.Value > RG_Nr Then
        'Druckbereich auswählen - Start
        Call CreateExcelAnlagen(Worksheets("RG-Anlage").Range(Cells(currentColumn - countRange + 1, 2), Cells(currentColumn - 1, RG_Column - 1)), RG_Nr, KundenNr)
        'ActiveSheet.range(Cells(currentColumn - countRange, 2), Cells(currentColumn - 1, RG_Column - 1)).ExportAsFixedFormat xlTypePDF, Filename:=ThisWorkbook.Path & "\Anlage " & RG_Nr & ".pdf"
        'Druckbereich auswählen - Ende
        RG_Nr = RG_Nr + 1
        currentColumn = currentColumn + 1
        countRange = 1
    ElseIf ActiveCell.Value < RG_Nr Then
        Exit For
    ElseIf ActiveCell.Value = RG_Nr Then
        currentColumn = currentColumn + 1
        countRange = countRange + 1
    End If
Next j
''''''''''MsgBox (rg_Nr & " ist " & countRange & " Spalten lang")

'Druckbereich auswählen - Start
Call CreateExcelAnlagen(Worksheets("RG-Anlage").Range(Cells(currentColumn - countRange + 1, 2), Cells(currentColumn - 1, RG_Column - 1)), RG_Nr, KundenNr)
'Druckbereich auswählen - Ende
Worksheets("RG-Anlage").Activate

End Sub

Private Function CreateExcelAnlagen(rRange As Range, RGNr As Integer, KundenNr As Long)
Dim tabWs As Worksheet
Dim strPfad As Variant
strPfad = ThisWorkbook.Path & "\" & "anlagen_excel"

ThisWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
Worksheets(Sheets.Count).Name = "AnlagenTab"

Set tabWs = ThisWorkbook.Worksheets("AnlagenTab")

    With tabWs
        .Activate
        
        .Cells(2, 1).Value = "Kundennummer: " & KundenNr
        .Cells(3, 1).Value = "Rechnungsnummer: " & Year(Date) & "-" & RGNr
        .Cells(4, 1).Value = "Datum: " & Date
        Worksheets("RG-Anlage").Activate
        Worksheets("RG-Anlage").Range(Cells(6, 2), Cells(6, Range(ActiveSheet.PageSetup.PrintArea).Columns.Count + 1)).Copy
        .Activate
        .Cells(6, 1).PasteSpecial Paste:=xlPasteColumnWidths
        .Cells(6, 1).PasteSpecial Paste:=xlPasteValues
        rRange.Copy
        .Cells(7, 1).PasteSpecial Paste:=xlPasteColumnWidths, SkipBlanks:=True
        .Cells(7, 1).PasteSpecial Paste:=xlFormats
        .Cells(7, 1).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
    End With

    'Überschrift Anlage zu Rechnung
    With tabWs.Cells(1, 1)
        .Value = "Anlage zu Rechnung"
        .Font.Size = 12
        .Font.Bold = True
    End With

    'Adresse einfügen
    With tabWs.Cells(1, tabWs.UsedRange.SpecialCells(xlCellTypeLastCell).Column)
        .Value = "WATERcontrol AG" & vbCrLf & "Alter Flughafen 16 B" & vbCrLf & "30179 Hannover"
        .EntireColumn.AutoFit
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    'Erste Zeile formatieren
    With tabWs.Cells(1, 1).EntireRow
        .Font.Bold = True
        .VerticalAlignment = xlCenter
    End With

    'Linien erzeugen
    With Cells(6, 1).CurrentRegion
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .BorderAround Weight:=xlThick
    End With

    'Überschriften in PDF Fett schreiben
    With Cells(6, 1).EntireRow
        .Font.Bold = True
        .WrapText = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    'Druckeinstellungen Ausrichtungen etc..
    With tabWs.PageSetup
        .Zoom = False
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    
    If Dir(strPfad, vbDirectory) <> "" Then
    Else
        MkDir strPfad
    End If
    
    tabWs.SaveAs Filename:=strPfad & "\" & RGr, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = False
    Worksheets("AnlagenTab").Delete
    Application.DisplayAlerts = True

End Function


Private Function KundenNr() As Long
Dim i As Integer
Dim KDNr As Long
Dim geWs As Worksheet 'Arbeitsblatt "gesamtexport"
Set geWs = ThisWorkbook.Worksheets("gesamtexport")

For i = 1 To geWs.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    If geWs.Cells(1, i) = "KDNummer" Then
        KDNr = geWs.Cells(2, i).Value
        Exit For
    End If
Next i

KundenNr = KDNr

End Function

Grüße,

Eyyub