AW: Vorschlag
12.10.2016 08:44:38
Uwe
Hallo Marcel,
in ein allgemeines Modul kommen die beiden Funktionen:
Public Function TextSaeubern(ByVal strT As String) As String
Const strS As String = "-.,:;#+'*?=)(/&%$§!~\}][{"
Dim i As Long
strT = Replace(strT, "ä", "ae")
strT = Replace(strT, "ö", "oe")
strT = Replace(strT, "ü", "ue")
strT = Replace(strT, "ß", "ss")
strT = Replace(strT, "Ä", "Ae")
strT = Replace(strT, "Ö", "Oe")
strT = Replace(strT, "Ü", "Ue")
strT = Replace(strT, " ", "_")
For i = 1 To Len(strS)
strT = Replace(strT, Mid(strS, i, 1), "_")
Next i
TextSaeubern = StripDuplicates(strT, "_")
'Mit Umwandlung meine ich:
'a) Umlaute: ae, oe, ue Schreibweise
'b) Leerzeichen: werden zum Unterstrich
'c) ß: zu ss
'd) Sonderzeichen: Unterstrich
'e) und dann noch: wenn mehrere Unterstriche dadurch hintereinander stehen so umwandeln, dass _
nur ein Unterstrich da steht
End Function
Public Function StripDuplicates(ByVal strZ As String, _
Optional ByVal sChar As String = " ") As String
' Entfernt mehrfach vorkommende Zeichen(-ketten) aus einem String
' http://www.vbarchiv.net/tipps/tipp_2215-doppelte-zeichen-aus-einem-string-entfernen.html
If strZ = String$(Len(strZ), sChar) Then
strZ = sChar
Else
While Len(strZ) > 0 And InStr(1, strZ, sChar & sChar) > 0
strZ = Replace(strZ, sChar & sChar, sChar)
Wend
End If
StripDuplicates = strZ
End Function
Im Modul "DieseArbeitsmappe" dann
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFile As String
If Me.Path = "" Then
strFile = Application.GetSaveAsFilename( _
"\\xxx-root-xxx\" & _
Format(Worksheets("Artikelsteckbrief").Range("L12").Value, "00\_0000\_0000_") & _
_
TextSaeubern(CStr(Worksheets("Artikelsteckbrief").Range("L14").Value)), _
"Excelarbeitsmappe mit Makros (*.xlsm), *.xlsm")
If Not CVar(strFile) = False Then
On Error Resume Next
Application.EnableEvents = False
Me.SaveAs strFile, 52
Application.EnableEvents = True
On Error GoTo 0
End If
Cancel = True
End If
End Sub
Gruß Uwe