Warum neu erstellte Datei nicht aktiv ?
21.01.2025 12:54:05
sigrid
mein Kollege hatte mir das Makro erstellt, welches einwandfrei funktioniert.
Das einzige Problem, wenn das Makro durchgelaufen ist, wird nicht die neuerstellte Datei
an der Oberfläche angezeigt.
Lasse ich das Makro im VBA Modus mit F8 Schritt für Schritt laufen, kommt keine Fehlermeldung
und die neu erstellte Datei ist zur weiteren Bearbeitung an der Oberfläche.
Vielleicht hat jemand eine Lösung ?
Public Sub Ins_aktuellen_Laufwerk_speichern()
Dim DateiNam As String
Dim aDatei As String
Dim strPath$
Dim akt, p As String
Dim strpathp
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
Application.Calculation = xlCalculationManual
' Application.Calculation = xlCalculationAutomatic
If Tabelle1.Range("O24") = "" Then
MsgBox "Sie müssen die MAIL-Adresse einsetzen !" _
& Chr(13) & "", _
48, " Hinweis für " & Application.Username
UF_Adresseingabe.Show
Exit Sub
End If
Dim tan
tan = Tabelle1.Range("P32") & ".xlsm" 'Name der Datei
ActiveSheet.Unprotect (getStrPassWort)
Dim WBName As String, varAntwortMsg
ActiveSheet.Range("D1") = WBName
If WBName = "" Then Exit Sub
'--- so jetzt noch ins Verzeichnis speichern -------------
Dim Fs As Object, OrdNam As Variant, Ord As Byte, Pfad As String
DateiNam = WBName & " " & "Rg.-Nr. " & ActiveSheet.Range("H24") & " " & ActiveSheet.Range("E23") & ".xlsm"
strPath = "D:\__Büro\"
With ActiveSheet
If IsDate(.Range("H29")) Then
If .Range("H29") > 0 Then
'Pfad Jahr
strPath = strPath & Year(.Range("H29").value) & "\"
'Pfad Monat
strPath = strPath & Format(.Range("H29").value, "MM MMMM") & "\"
'Ordner erstellen sollte dieser nicht vorhanden sein
apiCreateFullPath strPath
'Pfad Dateiname
strPath = strPath & DateiNam '''''''ActiveWorkbook.Name
'Prüfung ob vorhanden
If Dir(strPath, vbNormal) > "" Then
MsgBox "Kunden-Name " & DateiNam & Chr(13) & Chr(13) & _
"mit der Rg. - Nr. ist vorhanden !" & vbLf & vbLf & "Bitte ändern !"
' strPath = ActiveWorkbook.FullName
' On Error Resume Next
Application.DisplayAlerts = False
'' ActiveWorkbook.Close ''True
' Kill strPath
' ActiveWindow.Close
Exit Sub ' ich eingesetzt
'-----------------------------------------------------------
Else
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPassWort 'schützen
ActiveSheet.Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveWorkbook.SaveCopyAs Filename:=strPath
Application.EnableEvents = False
Workbooks.Open Filename:=strPath 'jetzt wird die gespeicherte nochmal
ActiveSheet.Name = Cells(32, 16).value 'namen als Tabellenname hinterlegen
' ActiveSheet.Application.ScreenUpdating = True
'' Call Sheets_löschen 'geöffnet um die restlichen Sheets zu löschen
Dim strFolder As String
If Dir$(strFolder, vbDirectory) = vbNullString Then
' MsgBox "Die ausgewählte Datei existiert nicht"
' MsgBox strFolder
MkDir strFolder
Else
' MsgBox "Die ausgewählte Datei existiert"
End If
'-------------------------------------------------------
Dim strPathPD
strPathPD = strFolder & strPath & DateiNam
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strPath
'--- hier pdf speichern rein ----------
strPath = Left(strPath, Len(strPath) - 5)
'hier Änderung in PDF/A format
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath
ActiveSheet.Application.ScreenUpdating = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
ActiveSheet.Range("P35") = ""
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPassWort 'schützen
End If
End If
End With
With Application
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Subgruß sigrid
Anzeige