ComputerBase Menü
Aktuelles

Excel VBA - Tabellenblatt als Arbeitsmappe Speichern in Schleife

E

Excelmania

Lieutenant
Registriert
Apr. 2010
Beiträge
797
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.
 
Kannst du ein Screenshoot der Fehlermeldung machen?
 
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?
 
Folgende Meldung erscheint:

Unbenannt.JPG


Die MSG-Box wird korrekt angezeigt.
 
Excelmania schrieb:
Die MSG-Box wird korrekt angezeigt.
Zum Vergrößern anklicken....
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"
 
Hallo.

Da kommt leider nichts.
Ergänzung ()

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
 
Zuletzt bearbeitet:
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"
Zum Vergrößern anklicken....
Wozu da über Debug.Print? Ctrl-C auf der MsgBox funktioniert normalerweise auch wunderbar...
 
Hallo.

Die Meldung der MSG-Box lautet:

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

Microsoft Excel

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

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

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

OK

---------------------------
 
Ich habe den Fehler gefunden!!

ActiveWorkbook.SaveAs Filename:=strOrdner & "\Finanz-Auswertung - " & ActiveSheet.Range("B3").Value & " - " & ActiveSheet.Range("E3").Value & ".xlsx"
 
  • Gefällt mir
Reaktionen: tollertyp
Du musst dich einloggen oder registrieren, um hier zu antworten.

Ähnliche Themen

E
Excel VBA - Tabellenblatt mit dem technischen Namen ansprechen?
Antworten
3
Aufrufe
5.366
Scientist
S
E
Excel VBA Tabellenblätter ausblenden außer bestimmte
Antworten
2
Aufrufe
6.791
cumulonimbus8
cumulonimbus8
E
Excel VBA - Schleife löscht Zeile nicht obwohl die Bedingung wahr sit
Antworten
7
Aufrufe
2.164
cumulonimbus8
cumulonimbus8
C
EXCEL VBA: Tabelle Filtern und automatisch via Mail versenden
Antworten
2
Aufrufe
4.087
Scientist
S
Allan Sche Sar
Excel VBA - Tabelle in Word Datei kopieren
Antworten
16
Aufrufe
5.949
cumulonimbus8
cumulonimbus8
Zurück
Oben

Willkommen auf ComputerBase!

Mit Werbung weiterlesen

Besuche ComputerBase wie gewohnt mit Werbung und Tracking. Die Zustimmung ist jederzeit widerrufbar.

Details im Privacy Center und in der Liste unserer Partner. Ein Widerruf ist möglich in der Datenschutzerklärung.

… oder ComputerBase Pro bestellen

Nutze ComputerBase ohne Werbebanner, Video-Ads und Werbetracking schon für 4 €/Monat oder 36 €/Jahr.

Mehr zu ComputerBase Pro

Bereits Pro-Nutzer? Hier anmelden.

Tracking: Wir und unsere 160 Partner verarbeiten personenbezogene Daten, indem wir mit auf Ihrem Gerät gespeicherten Informationen (z. B. eindeutige Kennungen in Cookies) ein Nutzungsprofil erstellen, um z. B. Anzeigen zu personalisieren. Verarbeitungszwecke: Genaue Standortdaten und Abfrage von Geräteeigenschaften zur Identifikation, Informationen auf einem Gerät speichern und/oder abrufen, Personalisierte Anzeigen und Inhalte, Anzeigen- und Inhaltsmessungen, Erkenntnisse über Zielgruppen und Produktentwicklungen.

Impressum Kontakt Datenschutz