Speichern unter Zelleninhalt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

HAllo Tom
Nimm als Ansatz mal sowas:

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Sub aufruf()
    Const PFAD As String = "C:\Test\"
    Dim Dateiname As String
    With Sheets("Tabelle1")
        Dateiname = .Range("A2").Text & .Range("A3").Text
    End With
    If Dateiname <> "" Then
        If erlaubt(Dateiname) = True Then
            On Error Resume Next
            ThisWorkbook.SaveAs Filename:=PFAD & Dateiname & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
        End If
        Else:
        MsgBox "A2 & A3 =""""", , "Speichern nicht möglich"
    End If
End Sub

Public Function erlaubt(strText As String) As Boolean
    'CON , PRN, AUX, CLOCK$, NUL # VERBOTEN #
    'COM0 , COM1, COM2, COM3, COM4, COM5, COM6, COM7, COM8, COM9 # VERBOTEN #
    'LPT0, LPT1, LPT2, LPT3, LPT4, LPT5, LPT6, LPT7, LPT8, und LPT9 # VERBOTEN #
    '< > ? " : | \ / # VERBOTEN #
    'Leerzeichen oder Punkt # VERBOTEN #
    Dim Regex
    erlaubt = True
    Set Regex = CreateObject("Vbscript.regexp")
    With Regex
        .Pattern = "^(CON|PRN|AUX|CLOCK$|NUL|COM0|COM1|COM2|COM3|COM4|COM5|COM6|COM7|COM8|COM9|LPT0|LPT1|LPT2|LPT3|LPT4|LPT5|LPT6|LPT7|LPT8| LPT9)\..*$"
        If .test(strText) = True Then
            erlaubt = False
            Exit Function
        End If
        .Pattern = "(<|>|\?|""|:|\||\\|\/|\*)"
        .Global = True
        If .test(strText) = True Then
            erlaubt = False
            Exit Function
        End If
        .Pattern = "( |\.).*\..*$"
        If .test(strText) = True Then
            erlaubt = False
            Exit Function
        End If
    End With
End Function

ransi

Public Sub aufruf() Const PFAD As String = "D:\Test\" Dim Dateiname As String With Sheets("Tabelle1") Dateiname = .Range("A2").Text & .Range("A3").Text End With If Dateiname "" Then Dateiname = fncErsetzenUnzulaessig(Dateiname) & ".xlsm" If Dir(PFAD & Dateiname) "" Then If MsgBox("Datei """ & Dateiname & """ existiert schon!" & vbLf _ & "Datei überschreiben?", _ vbYesNo + vbQuestion, _ "Datei speichern unter") = vbNo Then Exit Sub End If Application.DisplayAlerts = False ThisWorkbook.SaveAs Filename:=PFAD & Dateiname, _ FileFormat:=xlOpenXMLWorkbookMacroEnabled Application.DisplayAlerts = True Else MsgBox "A2 & A3 =""""", , "Speichern nicht möglich" End If End Sub Public Function fncErsetzenUnzulaessig(ByVal strText As String, _ Optional strSub As String = "_") As String ' Ersetzen von unzulässigen/unerwünschten Zeichen in Dateinamen Dim arrZeichen, intJ As Integer, strName As String arrZeichen = Array("", "?", """", ":", "|", "\", "/") 'unzulässige Zeichen strName = strText For intJ = LBound(arrZeichen) To UBound(arrZeichen) strName = VBA.Replace(Expression:=strName, Find:=arrZeichen(intJ), Replace:=strSub, _ Start:=1) Next fncErsetzenUnzulaessig = strName End Function

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread