variabler Dateipfad
16.12.2023 14:40:29
Heike
der folgende Code greift immer auf einen festen Dateipfad zu. Da sich dieser aber immer wieder ändert, möchte ich den gerne "variabel" haben. Der Dateiname ändert sich nicht. Zwar habe ich hier im Forum etwas gefunden über: Dim wbQuelle As Workbook; Dim wbZiel As Workbook, aber leider habe ich keine Ahnung, wie ich das in meinen Code einbinden soll.
Würde mich sehr freuen, wenn sich jemand meinen Code mal anschaut und vielleicht sogar korrigiert.
Vielen Dank im Voraus.
VG
Heike
Option Explicit
Private Sub Workbook_Open()
Application.ScreenUpdating = True 'muss auf True, ansonsten wird Windows(1) nicht aktiviert!!!
ChDir "C:\Users\Heike\Desktop\Vorlagen"
Workbooks.Open FileName:="C:\Users\Heike\Desktop\Vorlagen\Ausgangsbuch.xlsx"
Windows(1).Activate
If ThisWorkbook.Name = "Rechnungsvorlage.xltm" Then
Exit Sub
Else
Application.ScreenUpdating = False
Dim myWorksheet As Worksheet 'Passwort aufheben Rechnungsvorlage
For Each myWorksheet In ThisWorkbook.Worksheets
myWorksheet.Protect Password:="test123", userinterfaceonly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Next
Dim Datum As String
Datum = Format(Now, "dd.mm.yyyy") 'aktuelles Datum wird eingefügt
Range("G6") = Datum
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 'wird gespeichert, werden die Daten übertragen und RechnungsNR vergeben
On Error GoTo R_Error
If ThisWorkbook.Name = "Rechnungsvorlage.xltm" Then
Exit Sub
Else
Dim newNr As Variant, oldNr As Variant
Dim FileName As String
FileName = "C:\Users\Heike\Desktop\Vorlagen\Rechnung.ini"
If Range("G4") > "" Then Exit Sub
Close #1
restart:
Open FileName For Input As #1
Line Input #1, oldNr
Close #1
newNr = oldNr + 1
Open FileName For Output As #1
Write #1, newNr
Close #1
Select Case Len(newNr)
Case 1
newNr = "000" & newNr
Case 2
newNr = "00" & newNr
Case 3
newNr = "0" & newNr
Case 4
newNr = newNr
Case 5
MsgBox "Zahlenlimit überschritten"
Exit Sub
End Select
Range("G4") = newNr & "-23"
R_Exit:
'Exit Sub
GoTo Weiter
R_Error:
Select Case Err
Case 53
Open FileName For Output As #1
Close #1
Open FileName For Output As #1
Write #1, 0
Close #1
Err.Clear
Resume restart
Case 54
Close #1
Resume restart
Case Else
MsgBox Err & ": " & Err.Description
Resume R_Exit
End Select
Weiter:
Workbooks("Ausgangsbuch.xlsx").Activate
Windows(1).Activate
If Range("G4") > "" Then
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim iRow As Integer
Dim chkStr As String
Set wksSource = Worksheets("Rechnung")
Set wksTarget = Workbooks("Ausgangsbuch.xlsx").Worksheets(1)
' chkStr = wksSource.Range("A11").Value
iRow = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
wksTarget.Cells(iRow, 1).Value = wksSource.Range("G4").Value 'RE-Nr
wksTarget.Cells(iRow, 2).Value = wksSource.Range("G6").Value 'Datum
wksTarget.Cells(iRow, 3).Value = wksSource.Range("A3").Value 'Empfänger1
wksTarget.Cells(iRow, 4).Value = wksSource.Range("A4").Value 'Empfänger2
wksTarget.Cells(iRow, 5).Value = wksSource.Range("A5").Value 'Straße
wksTarget.Cells(iRow, 6).Value = wksSource.Range("A6").Value 'Ort
wksTarget.Cells(iRow, 7).Value = wksSource.Range("G34").Value 'Gesamtbetrag
End If
Workbooks("Ausgangsbuch.xlsx").Activate
'ActiveWorkbook.Worksheets("Rechnungsausgangsbuch").Protect "test456"
ActiveWorkbook.Close SaveChanges:=True
Windows(1).Activate
Rem Bildschirmmeldung deaktivieren
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
"\\C:\Users\ Heike\Desktop\Vorlagen\Rechnungen_AJ\" & Range("G4") & "_" & Range("A4").Text & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
ActiveWorkbook.Close SaveChanges:=False
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End If
End Sub