Combobox Jahr auswählen und als Überschrift

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) Sheets("Tabelle1").Range("A2") = ComboBox1.Value Sheets("Tabelle2").Range("Z1") = ComboBox1.Value Sheets("Tabelle3").Range("B10") = ComboBox1.Value End Sub

Private Sub CommandButton1_Click() Worksheets(1).Range("DasTextJahr").Value = Me.ComboBox1.Value Me.Hide End Sub Private Sub UserForm_Initialize() With Me.ComboBox1 .AddItem "2010" .AddItem "2011" .AddItem "2012" .AddItem "2013" .AddItem "2014" .AddItem "2015" .AddItem "2016" .AddItem "2017" .AddItem "2018" .AddItem "2019" .AddItem "2020" .AddItem "2021" .AddItem "2022" .AddItem "2023" .ListIndex = 3 'Vorbelegung "2013" bei Formularstart End With End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) On Error GoTo Fehler Dim NName As String Cancel = True NName = Worksheets(1).Range("DasTextJahr").Value & " " & ThisWorkbook.Name Application.EnableEvents = False ThisWorkbook.SaveAs NName Err.Clear Fehler: Application.EnableEvents = True If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Makro1() ' MVT 1 Seite 1 befüllen von Tab1.3 Sheets("Tab1.3").Range("E16:U38").Copy Sheets("MVT 1 Seite 1").Range("E14:U36").PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Tab1.3").Range("E40:U62").Copy Sheets("MVT 1 Seite 1").Range("E40:U62").PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Tab1.3").Range("E64:U86").Copy Sheets("MVT 1 Seite 1").Range("E66:U88").PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Call Makro2 End Sub

Sub SpeichernAls() On Error GoTo Fehler Dim Pfad As String, NName As String, Ext As String, WB As Workbook, Jahr As String Pfad = "C:\Temp\Test\" NName = "Das wäre der Name" Ext = ".xlsx" Jahr = Worksheets(1).Range("DasTextJahr").Value Sheets(Array("MVT 1 Seite 1", "MVT 1 Seite 2", "MVT 1 Seite 3", "MVT 1 Seite 4", _ "MVT 1 Regional")).Copy ActiveSheet.SaveAs Filename:=Pfad & NName & "_" & _ Jahr & Ext, FileFormat:=xlOpenXMLWorkbook ThisWorkbook.Close True Err.Clear Fehler: Application.EnableEvents = True If Err.Number 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Hallo
zu 2)
Du hast zwar keinen Excel/VBA Level angegeben, aber in der Musterdatei bewiesen, dass du
Makros anpassen kannst.
Ich habe das Makro bei mir getestet.
Wenn dort steht, Pfad nicht vorhanden..
musst du natürlich an deine Gegebenheiten anpassen. Achte auf das abschließende \
Pfad = "C:\Temp\Test\" 'das ist MEIN Speicherpfad
NName = "Das wäre der Name"
ebenso der gewünschte Dateiname.
zu 1)
- das Makro muss in die Datei, wo du per Userform auswählst
- durch Sheets(Array("M... werden nur die anderen Blätter in eine neue Datei kopiert
= Ich habe nachgesehen, in den Blättern selbst ist bei dir kein Code enthalten
= Also darf die Meldung "ohne Makros gespeichert wird" nicht erscheinen
- durch ActiveSheet.SaveAs .. wird die neu geöffnete/erzeugte Datei gespeichert als xlsx
Wie gesagt, bei mir ohne Probleme
LG UweD

Option Explicit Sub SpeichernAls() Dim Pfad As String, NName As String, Ext As String, Jahr As String Dim Dlg As FileDialog On Error GoTo Fehler '** Anpassungen Pfad = "C:\Temp\Test\" 'Der Startpfad NName = "Das wäre der Name" Ext = ".xlsx" '** Jahr = Worksheets(1).Range("DasTextJahr").Value 'Verzeichnis wählen Set Dlg = Application.FileDialog(msoFileDialogFolderPicker) With Dlg .AllowMultiSelect = False .InitialFileName = Pfad .Title = "Speicherort auswählen" End With If Dlg.Show = True Then Pfad = Dlg.SelectedItems(1) & "\" 'Neue Datei erstellen ThisWorkbook.Sheets(Array("MVT 1 Seite 1", "MVT 1 Seite 2", "MVT 1 Seite 3", _ "MVT 1 Seite 4", "MVT 1 Regional")).Copy 'Die neue Datei speichern ActiveSheet.SaveAs Filename:=Pfad & NName & "_" & Jahr & Ext, _ FileFormat:=xlOpenXMLWorkbook 'Die ursprüngliche Datei schliessen ThisWorkbook.Close True 'False= ohne speichern schliessen End If Err.Clear Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Hallo
Lässt du das Makro im Einzelschrittmodus durchlaufen und wechselst evtl währenddessen die Datei?
Es kann nur an der aktivierung der 2 Dateien liegen, dass diese vertauscht werden.
Hier ein workarround, wo die Dateien explizit benannt werden.
Bitte änder im Kopf den Dateinamen auf deine Datei ab.

Sub SpeichernAls()
    Dim Pfad As String, NName As String, Ext As String, Jahr As String
    Dim Dlg As FileDialog, WBM As Workbook, WBNeu As Workbook
    On Error GoTo Fehler
    
    '** Anpassungen 
    Set WBM = Workbooks("Master.xlsm") ' Diese Datei 
    Pfad = "C:\Temp\Test\" 'Der Startpfad 
    NName = "Das wäre der Name"
    Ext = ".xlsx"
    '** 
    
    Application.ScreenUpdating = False
    Jahr = WBM.Worksheets(1).Range("DasTextJahr").Value
    
    'Verzeichnis wählen 
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    With Dlg
        .AllowMultiSelect = False
        .InitialFileName = Pfad
        .Title = "Speicherort auswählen"
    End With
    
    If Dlg.Show = True Then
        Pfad = Dlg.SelectedItems(1) & "\"
        
        'Neue Datei erstellen 
        Set WBNeu = Workbooks.Add
        
        'Blätter kopieren 
        WBM.Sheets(Array("MVT 1 Seite 1", "MVT 1 Seite 2", "MVT 1 Seite 3", _
            "MVT 1 Seite 4", "MVT 1 Regional")).Copy after:=WBNeu.Sheets(1)
        
        'Erstes Blatt der Neuen Datei löschen 
        Application.DisplayAlerts = False
        WBNeu.Sheets(1).Delete
        Application.DisplayAlerts = True

        'Die neue Datei schpeichern 
        WBNeu.SaveAs Filename:=Pfad & NName & "_" & Jahr & Ext, _
            FileFormat:=xlOpenXMLWorkbook
        
        'Die ursprüngliche Datei achliessen 
        WBM.Close True 'False= ohne speichern schliessen 
    End If
    Err.Clear
Fehler:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Combobox Jahr auswählen und als Überschrift

35
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Combobox Jahr auswählen und als Überschrift

35 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

35
Beiträge zum Forumthread

Beiträge zu diesem Forumthread