VBA Tabelle Speichern unter mit fortlaufender zahl

[Krause-r-h]

  Master.xlsm (Größe: 45,18 KB / Downloads: 4)

Moin alle miteinander
Wenn ich Euch jetzt mein Problem Erkläre werdet ihr Sicher Sagen das ist ja nicht so schwer.
Für mich schon.
Ich habe ja auch von einem User aktive Hilfe bekommen in Form eines Buches,
fand ich richtig Top!!!!
Aber ich komme manchmal nicht so voran wie ich es gerne möchte.

Nun gut, wie fange ich an?
Ich möchte mit Vba ein Formular Speichern unter einem Pfad und der Dateiname wird aus einer Celle (bzw. 2 Cellen ) erstellt.
Nach dem Speichern soll das Formular mit der nächsten Blattnummer wieder sichtbar sein um es erneut Auszufüllen ,und da komme ich nicht weiter
Das ist meine Sub bisher

'Sub FormularLeeren()

ActiveWorkbook.SaveAs "e:\" & Range("AD1").Value & Range("AF1").Value & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Workbooks.Open Filename:="e:\Master.xlsm"
Workbooks("Master.xlsm").Activate
Workbooks(1).Close

'End Sub

Beispiel lade Euch hoch .
Soweit so gut, wie oder mit welcher Methode kann ich erreichen das
Beispiel "Master.xlsm" die Startdatei ist, in die ich Daten eintrage .
Diese wird unter "Blatt1.xlsm" gespeichert und geschlossen.
Danach öffnet sich die ‘‘Master.xlsm“ mit "Blatt2" usw.(AD1 ist Blatt AF1 die Nr.)
Habt ihr eine Idee oder einen Lösungsvorschlag.
Ich wäre euch sehr Dankbar.
Viele Grüße aus dem Lauenburg Ronny

[Gast 123]

Hallo

warum viele "krumme Wege" gehen, wenn man bequem gerade auslaufen kann??  Der untere Code erstellt eine neue Datei als xlsx und ohne Button!!
Die neue Datei bleibt geöffnet damit man das Blatt direkt bearbeiten kann. Ob man das Original schliesst musst du entscheiden. Im Augenblick Ja.

mfg  Gast 123

Code:

Sub FormularLeeren()
Dim Datei As String, Nummer As Long
With ThisWorkbook.Worksheets("BETONPRÜFUNG leer")
    On Error GoTo Fehler
    'Nummer erst beim Erstellen erhöhen!!
    Nummer = .Range("AF2").Value + 1
    If Nummer = Empty Then MsgBox "Keine Nummer vorhanden": Exit Sub
    Datei = "E:\" & .Range("AD1") & Nummer & ".xlsx"
    'dieses Blatt kopieren und umbenennen  (Button löschen!!)
    Worksheets("BETONPRÜFUNG leer").Copy
    ActiveWorkbook.Sheets(1).Shapes(1).Delete
    ActiveWorkbook.Sheets(1).Range("AF1") = Nummer
    ActiveWorkbook.Sheets(1).Range("AF2") = Nummer - 1
    ActiveWorkbook.Sheets(1).Name = "BETONPRÜFUNG"
    'unter neuem Datei Namen speichern und Offen lassen!!
    ActiveWorkbook.SaveAs Datei, FileFormat:=xlNormal, CreateBackup:=False
    'jezt letzte Nummer notieren, ThlsDatei schliessen
    .Range("AF2").Value = Nummer
    ThisWorkbook.Save
    ThisWorkbook.Close
End With
Exit Sub
Fehler:  MsgBox "Unerwarteter Fehler aufgetreten"
End Sub

[LuckyJoe]

Hallo Ronny,

falls du folgenden Ansatz suchst, kopiere diesen Code in "DieseArbeitsmappe":

Code:

Option Explicit

Private Sub Workbook_Open()
    
    strDateipfad = "e:\"
    strDateiname = Range("AD1")
    iLfdNr = 0
    strDatei = strDateipfad & strDateiname & iLfdNr & ".xlsx"

    Do
        strDatei = strDateipfad & strDateiname & iLfdNr & ".xlsx"
        If Len(Dir(strDatei)) = 0 Then Exit Do
        iLfdNr = iLfdNr + 1
    Loop
    
    Range("AF1") = iLfdNr

End Sub

und folgenden Code in dein bisheriges Modul (Modul1):

Code:

Option Explicit

Public strDateipfad As String
Public strDateiname As String
Public strDatei As String
Public iLfdNr As Integer

Sub FormularLeeren()
    
    iLfdNr = Range("AF1")
    strDatei = strDateipfad & strDateiname & iLfdNr & ".xlsx"
        
    If Len(Dir(strDatei)) > 0 Then
        MsgBox strDatei & " existiert bereits!"
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs strDatei
    ActiveWorkbook.Close
    MsgBox strDatei & " gespeichert."
    Range("AF1") = Range("AF1") + 1
    Application.DisplayAlerts = True
    
End Sub

Viel Erfolg.

[Krause-r-h]

Moin Lucky Joe
Ich danke dir erst mal und werde deine Vorschläge gleich mal testen

Erst mal vielen Dank und ein schönen Sonntag wünsche ich dir noch.

Grüße aus Lauenburg Ronny

[Krause-r-h]

Hallo Gast

Hm keine Ahnung warum ich immer um die ecke denken muß war schon immer so,aber danke für deinen Lösungsvorschlag werde ihn gleich mal testen.


Schönen Sonntag noch Ronny

[Krause-r-h]

[quote='LuckyJoe' pid='149213' dateline='1549188091']
Hallo Ronny,

falls du folgenden Ansatz suchst, kopiere diesen Code in "DieseArbeitsmappe":

Code:

Option Explicit

Private Sub Workbook_Open()
    
    strDateipfad = "e:\"
    strDateiname = Range("AD1")
    iLfdNr = 0
    strDatei = strDateipfad & strDateiname & iLfdNr & ".xlsx"

    Do
        strDatei = strDateipfad & strDateiname & iLfdNr & ".xlsx"
        If Len(Dir(strDatei)) = 0 Then Exit Do
        iLfdNr = iLfdNr + 1
    Loop
    
    Range("AF1") = iLfdNr

End Sub

und folgenden Code in dein bisheriges Modul (Modul1):

Code:

Option Explicit

Public strDateipfad As String
Public strDateiname As String
Public strDatei As String
Public iLfdNr As Integer

Sub FormularLeeren()
    
    iLfdNr = Range("AF1")
    strDatei = strDateipfad & strDateiname & iLfdNr & ".xlsx"
        
    If Len(Dir(strDatei)) > 0 Then
        MsgBox strDatei & " existiert bereits!"
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs strDatei
    ActiveWorkbook.Close
    MsgBox strDatei & " gespeichert."
    Range("AF1") = Range("AF1") + 1
    Application.DisplayAlerts = True
    
End Sub

Viel Erfolg.

So mein Bester erst mal vielen Dank für deine Hilfe.
Ich habe erst nicht verstanden warum ich einen zweiten Code brauche,jetzt weis ich warum und bin wieder etwas schlauer.
Ich hab noch ein paar Sachen hinzugefügt, war ja jetzt einfach, und jetzt funktioniert es auch so wie ich es vor hatte.
Nochmal Danke für deine Hilfe.
Ich wünsche Dir eine schöne Woche.
LG aus Lauenburg Ronny

[LuckyJoe]

... schön, dass ich helfen konnte.