Excel VBA - Tabellenblatt als Arbeitsmappe Speichern in Schleife

Excelmania · 26. Januar 2021

Hallo.

Ich habe eine Excel-Datei, die aus zwei Exporten aus zwei verschiedenen Datenbanken gespeist wird.

Die Daten werden für die Bearbeitung aufbereitet. Damit nur die Daten, die für die Organisationseinheiten relevant sind, auch diesen zugestellt werden, habe ich ein Makro erstellt mit dem das formelbasierte Tabellenblatt in eine eigene Excel-Datei kopiert wird.

Als Einzellösung klappt es auch. In einer Schleife kommt es jedoch zu einem Fehler.

Vielleicht könnte Ihr mir helfen?

Code:

Private Sub AW_OE_CB_Excelserie_Click()

    Dim k As Integer
    Dim varFilename As Variant
    Dim objShape As Shape
    TBName = ActiveSheet.Name

'Variablen Organisationseinheit
OeS = Worksheets("Optionen").Range("B12").Value
OeZ = Worksheets("Optionen").Range("B18").Value
OlZ = Worksheets("Optionen").Range("B19").Value
k = OeZ

'Variablen Ziel:AW_OE
ZeS = Worksheets("Optionen").Range("B71").Value
ZlS = Worksheets("Optionen").Range("B91").Value
ZeZ = Worksheets("Optionen").Range("B96").Value
ZlZ = Worksheets("Optionen").Range("B97").Value

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationAutomatic
End With

    Dim strOrdner As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Ordnerauswahl"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strOrdner = .SelectedItems(1)
            If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
                     
           'Schleife OE - Anfang
            With Worksheets("Auswertung")
                For k = OeZ To OlZ
                    .Range(OeS & k).Copy
                        Worksheets("AW_OE").Range("B3").PasteSpecial Paste:=xlPasteValues
                        Call AW_OE_anzeigen
                       
    'Tabellenblatt kopieren
    Worksheets(TBName).Copy
    Application.DisplayAlerts = False
   
       'Schaltflächen löschen
    For Each objShape In ActiveWorkbook.ActiveSheet.Shapes
      If Not Application.Intersect(objShape.TopLeftCell, ActiveWorkbook.ActiveSheet.Range("O1:T20")) Is Nothing Then
        objShape.Delete
      End If
    Next
     
    'Formeln durch Festwerte ersetzen
    ActiveWorkbook.ActiveSheet.Range("D6:O17").Copy
    ActiveWorkbook.ActiveSheet.Range("D6:O17").PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False
         
    'Dropdownauswahl löschen
    Z = ActiveWorkbook.ActiveSheet.Range("B3").Value
    ActiveWorkbook.ActiveSheet.Range("B3").Clear
    ActiveWorkbook.ActiveSheet.Range("B3").Value = Z
   
    X = ActiveWorkbook.ActiveSheet.Range("E3").Value
    ActiveWorkbook.ActiveSheet.Range("E3:F3").Clear
    ActiveWorkbook.ActiveSheet.Range("E3").Value = X
   
    'Formatierung Stammdaten wiederherstellen
    ActiveWorkbook.ActiveSheet.Range("E3,B3").Select
    ActiveWorkbook.ActiveSheet.Range("B3").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13434879
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
   
    'Individuelle Flaz-Phasen ausblenden
    ActiveWorkbook.ActiveSheet.Range("R:U").EntireColumn.Hidden = True
           
    'Blattschutz setzen
    ActiveWorkbook.ActiveSheet.Protect
   
    'A1 auswählen
    ActiveWorkbook.ActiveSheet.Range("A1").Select
       
    'Speichern
   
            ActiveWorkbook.SaveAs (strOrdner & "\Finanzauswertung-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx")
           
           'Schließen
            ActiveWorkbook.Close
           
           'Schleife OE - Ende
                Next k
            End With
           
           
          Else
            strOrdner = ""
        End If
    End With

' A2 Selektieren
ActiveSheet.Range("A2").Select

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationAutomatic
End With

End Sub

Der Debugger bleibt bei ActiveWorkbook.SaveAs (strOrdner & "\Finanzauswertung-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx") hängen.

G-Red · 26. Januar 2021

Kannst du ein Screenshoot der Fehlermeldung machen?

tollertyp · 26. Januar 2021

Du könntest vorher auch mal

Code:

MsgBox strOrdner & "\Finanzauswertung-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx"

machen. Einfach um zu schauen, ob der Name Sinn ergibt.

Kann es sein, dass es die Datei bereits gibt?

Excelmania · 26. Januar 2021

Folgende Meldung erscheint:

Die MSG-Box wird korrekt angezeigt.

G-Red · 26. Januar 2021

Excelmania schrieb:
Die MSG-Box wird korrekt angezeigt.

Kannst du den Inhalt des Strings hierher posten, so wie der ausgegeben wird?

Code:

Debug.Print strOrdner & "\Finanzauswertung-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx"

Excelmania · 26. Januar 2021

Hallo.

Da kommt leider nichts.

Ergänzung (26. Januar 2021)

Als PDF funktioniert es.

Code:

Private Sub CMD_AW_OE_SPDF_Click()

Dim k As Integer

'Variablen Organisationseinheit
OeS = Worksheets("Optionen").Range("B12").Value
OeZ = Worksheets("Optionen").Range("B18").Value
OlZ = Worksheets("Optionen").Range("B19").Value
k = OeZ

'Variablen Ziel:AW_OE
ZeS = Worksheets("Optionen").Range("B71").Value
ZlS = Worksheets("Optionen").Range("B91").Value
ZeZ = Worksheets("Optionen").Range("B96").Value
ZlZ = Worksheets("Optionen").Range("B97").Value

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationAutomatic
End With

    Dim strOrdner As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Ordnerauswahl"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strOrdner = .SelectedItems(1)
            If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
                      
           'Schleife OE - Anfang
            With Worksheets("Auswertung")
                For k = OeZ To OlZ
                    .Range(OeS & k).Copy
                        Worksheets("AW_OE").Range("B3").PasteSpecial Paste:=xlPasteValues
                        Call AW_OE_anzeigen
                        
                    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    strOrdner & "\Finanz-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".pdf", Quality:=xlQualityStandard _
                    , IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish _
                    :=False
            
           'Schleife OE - Ende
                Next k
            End With
            
            
          Else
            strOrdner = ""
        End If
    End With

' A2 Selektieren
ActiveSheet.Range("A2").Select

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationAutomatic
End With

end sub

tollertyp · 26. Januar 2021

Dann wiederhole ich die Frage halt. Kann es sein, dass es die Datei bereits gibt?

G-Red schrieb:
Kannst du den Inhalt des Strings hierher posten, so wie der ausgegeben wird?

Code:

Debug.Print strOrdner & "\Finanzauswertung-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx"

Wozu da über Debug.Print? Ctrl-C auf der MsgBox funktioniert normalerweise auch wunderbar...

Excelmania · 26. Januar 2021

Hallo.

Die Meldung der MSG-Box lautet:

---------------------------

Microsoft Excel

---------------------------

C:\Users\XT75302\Desktop\\Finanzauswertung-Auswertung - 91 - 2021-03.xlsx

---------------------------

OK

---------------------------

tollertyp · 26. Januar 2021

Bin raus. Ein drittes Mal frage ich nicht.

Excelmania · 26. Januar 2021

Ich habe den Fehler gefunden!!

ActiveWorkbook.SaveAs Filename:=strOrdner & "\Finanz-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx"

Suche

Excel VBA - Tabellenblatt als Arbeitsmappe Speichern in Schleife

Excelmania

Lieutenant

G-Red

Commander

tollertyp

Fleet Admiral

Excelmania

Lieutenant

G-Red

Commander

Excelmania

Lieutenant

tollertyp

Fleet Admiral

Excelmania

Lieutenant

tollertyp

Fleet Admiral

Excelmania

Lieutenant

Ähnliche Themen