Excel VBA

Liebe Community!


Ich habe Office 365.

Ich habe eine Excel Vorlage mit VBA Codes. Diese Vorlage hat jetzt 3 Jahre perfekt funktioniert.

Vor 1 Woche hat es auch noch besten funktioniert. und heute bekomme ich die Fehlermeldung: Die Methode 'open' für das Objekt 'Workbooks' ist fehlgeschlagen.


Wenn ich die Datei neu öffne -> Code ausführe -> bei Fehlermeldung "debuggen" -> "Fortsetzen "F5" -> Der Fehler wird übersprungen und die save as Methode ist fehlgeschlagen.


Ich bitte um Hilfe.


Der Code:

'USERFORM TEXT ÜBERNEHMEN





Worksheets"Erfassung".Range"Erfassung_Kommisinsnr".Value = Me.tb_kommisionsnr

Worksheets"Erfassung".Range"Erfassung_Lieferzeit".Value = Me.tb_Lieferzeit

Worksheets"Erfassung".Range"Erfassung_ProjektBez".Value = Me.tb_Projektname



'USERFORM ENDE



'Prüfen ob Projektname existiert



If Tabelle6.Cells12, 4 = "" Then

msgbox "Sie haben keinen Projekt-Namen definiert! Tragen Sie den Namen in der Textbox ein und klicken Sie auf Fortfahren!", vbOKOnly





Exit Sub

End If





'Projektnummer als Variable definieren



Dim Auftrag As String

Auftrag = Tabelle6.Cells2, 4



'Prüfen ob Ordner existiert



Dim fso As Object

Set fso = CreateObject"Scripting.FileSystemObject"



Dim path As String

directoryName = Environ"UserProfile" & "\Google Drive\GMU\Projekte\" & Auftrag & "\"

If fso.FolderExistsdirectoryName Then

GoTo Angebot





End If







'Projekt - Name übernehmen



Tabelle6.Cells12, 4.Copy



'Projekt - Nummer generieren



Dim myWBok As Workbook

Set myWBok = Workbooks.OpenEnviron"UserProfile" & "\Google Drive\GMU\Projekte\Fortlaufende Nummer - Kopie.xlsx"



myWBok.Activate



Dim tabAuftrNr

Set tabAuftrNr = myWBok.Worksheets"Auftragsnummern"



tabAuftrNr.Activate





Zeile = CellsRows.Count, 2.EndxlUp.Row



tabAuftrNr.CellsZeile + 1, 1 = tabAuftrNr.CellsZeile, 1 + 1

tabAuftrNr.CellsZeile + 1, 2 = "'" & FormatDate, "yyyy"

tabAuftrNr.CellsZeile + 1, 3 = "'" & FormatDate, "dd"

tabAuftrNr.CellsZeile + 1, 4 = "'" & FormatDate, "mm"



If tabAuftrNr.CellsZeile + 1, 3 = tabAuftrNr.CellsZeile, 3 Then

tabAuftrNr.CellsZeile + 1, 5 = tabAuftrNr.CellsZeile, 5 + "01"



Else

tabAuftrNr.CellsZeile + 1, 5 = "01"

End If









tabAuftrNr.CellsZeile + 1, 7.Select

ActiveSheet.Paste



Dim xyz As String

xyz = tabAuftrNr.CellsZeile + 1, 6











myWBok.Save

myWBok.Close



Set myWBok = Nothing



'Projekt - Nummer einfügen



Tabelle6.Cells11, 4.Value = xyz





'Ordner bezeichnung nach Prüfung als Variable



Dim Projekt As String

Projekt = Tabelle6.Cells2, 4





If Tabelle6.Cells2, 4 = "fehlt" Then

msgbox "Projekt - Name Zeile 12, Spalte 4 fehlt", vbOKOnly

Exit Sub

End If





Dim AuftrDatei As Workbook

Set AuftrDatei = ThisWorkbook











Dim objNewFolder As Object

Dim objFolder As Object



Dim objOutApp As Object

Dim objName As Object

On Error GoTo Fin

Set objOutApp = CreateObject"Outlook.Application"

Set objName = objOutApp.GetNamespace"MAPI"





' 6 = olFolderInbox

Set objFolder = objName.GetDefaultFolder6



Set objNewFolder = objFolder.Folders.AddProjekt

Fin:

If Err.Number <> 0 Then msgbox "Fehler: " & _

Err.Number & " " & Err.Description

Set objNewFolder = Nothing

Set objFolder = Nothing



Set objName = Nothing

Set objOutApp = Nothing







fso.Createfolder directoryName



Unload Me







'Ende Projekt erstellen und Ende Ordner erstellen







Angebot:



Dim ProjektAngebot As String

ProjektAngebot = Tabelle6.Cells2, 4



'Angebot NUMMER GENERIEREN







'Dokumentart einfügen

Tabelle6.Cells4, 3 = "Angebot"

'Projekt - Name übernehmen



Tabelle6.Cells12, 4.Copy



'Nummer generieren



Dim myWBk As Workbook

Set myWBk = Workbooks.OpenEnviron"UserProfile" & "\Google Drive\GMU\Projekte\Fortlaufende Nummer - Kopie.xlsx"



myWBk.Activate



Dim tabAngebotsnummern

Set tabAngebotsnummern = myWBk.Worksheets"Angebotsnummern"

tabAngebotsnummern.Activate



Zeile = CellsRows.Count, 2.EndxlUp.Row



tabAngebotsnummern.CellsZeile + 1, 1 = tabAngebotsnummern.CellsZeile, 1 + 1

tabAngebotsnummern.CellsZeile + 1, 2 = "A"

tabAngebotsnummern.CellsZeile + 1, 3 = "'" & FormatDate, "mm"

tabAngebotsnummern.CellsZeile + 1, 4 = "'" & FormatDate, "yy"



If tabAngebotsnummern.CellsZeile + 1, 3 = tabAngebotsnummern.CellsZeile, 3 Then

tabAngebotsnummern.CellsZeile + 1, 5 = tabAngebotsnummern.CellsZeile, 5 + "001"



Else

tabAngebotsnummern.CellsZeile + 1, 5 = "001"

End If











tabAngebotsnummern.CellsZeile + 1, 7.Select

ActiveSheet.Paste





Dim xx As String

xx = tabAngebotsnummern.CellsZeile + 1, 6.Value



'Tabelle1.Cells10, 12.Value = xyz

'tabAngebotsnummern.Cellszeile + 1, 6.Copy



myWBk.Save

myWBk.Close



Set myWBk = Nothing



'Angebotsnummer einfügen







Tabelle6.Cells4, 4.Value = xx



'Angebot speichern





If Tabelle1.Cells4, 4 = "" Then

msgbox "Dokumentnummer fehlt", vbOKOnly

Exit Sub

End If







'prüfen ob ordner existiert



Dim fsoAngebot As Object

Set fsoAngebot = CreateObject"Scripting.FileSystemObject"

Dim pathAngebot As String

directoryNameAngebot = Environ"UserProfile" & "\Google Drive\GMU\Projekte\" & ProjektAngebot & "\"

If fso.FolderExistsdirectoryNameAngebot Then

GoTo Finish

End If

fsoAngebot.Createfolder directoryNameAngebot









Dim DokName

Set DokName = Tabelle6.Cells2, 5





Debug.Print



Finish:

ActiveWorkbook.SaveAs directoryName & DokName & ".xlsm"

If Tabelle6.Cells40, 3 = "" Then

SeiteEnde = 1

Else

SeiteEnde = Tabelle6.Cells40, 3

End If









SeiteStart = 1



Tabelle1.Select



ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

directoryNameAngebot & DokName _

, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _

:=False, From:=SeiteStart, To:=SeiteEnde, OpenAfterPublish:=True





'Angebot ENDE



'Angebot in CacheSheet übergeben













Unload Me

Tabelle6.Select





End Sub




Vielen Dank für eure Hilfe!