AW: Dateien in Excel anzeigen und umbenennen
16.04.2010 15:48:07
fcs
Hallo Karsten,
die folgen beiden Prozeduren muss austauschen.
Dann werden im Blatt2 "nur" in Spalte B die bereinigten Namen ausgegeben.
Gruß
Franz
Sub Hyroglyphen_auswerten()
Dim wksHyro As Worksheet, lZeile As Long
Dim sDateiNameNeu As String, vAuswahl As Variant
vAuswahl = MsgBox("Hyroglyphen auswerten", vbQuestion + vbYesNo, _
"Neue Dateien ermitteln")
If vAuswahl = vbYes Then
Set wksHyro = Worksheets("Tabelle2")
With wksHyro
.Columns(2).Clear 'in diese Spalte wird der ermittelte neue Dateiname eingetragen
.Cells(1, 2) = "Neuer Name, berechnet"
For lZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'neuen Dateinamen ermitteln
sDateiNameNeu = fncNeuerName(sText:=.Cells(lZeile, 1))
.Cells(lZeile, 2) = sDateiNameNeu
Next
.Range(.Columns(1), .Columns(2)).EntireColumn.AutoFit
.Activate
End With
End If
End Sub
Function fncNeuerName(sText As String) As String
Dim iI As Long, iPos_Datei As Long, bOk As Boolean
Dim R_Nr As Long, Datei_Nr As Long, vZeichen
'Dateiname aus Hyroglyphenn ermitteln
fncNeuerName = sText
fncNeuerName = Trim(fncNeuerName) 'Leerzeichen links und rechts weg
'? unzulässig in Dateinamen ersetzen durch Zeichen 191 - spanisches ?
fncNeuerName = VBA.Replace(fncNeuerName, "?", Chr(191))
'Sonderzeichen am Anfang löschen
bOk = False
Do
Select Case Asc(Left(fncNeuerName, 1))
Case 40, 41, 64, 95 ' (, ), @, _,
bOk = True
Case 65 To 90, 97 To 122 'A bis Z , a bis z
bOk = True
Case 128, 191 To 255 ', internationale Sonderzeichen, inkl. ä,ö,ü, Ä,Ö,Ü, ß
bOk = True
End Select
If bOk = False Then
fncNeuerName = Mid(fncNeuerName, 2)
End If
Loop Until bOk = True
'Sonderzeichen am Ende löschen
bOk = False
Do
Select Case Asc(Right(fncNeuerName, 1))
Case 40, 41, 64, 95 ' (, ), @, _,
bOk = True
Case 65 To 90, 97 To 122 'A bis Z , a bis z
bOk = True
Case 128, 191 To 255 ', internationale Sonderzeichen, inkl. ä,ö,ü, Ä,Ö,Ü, ß
bOk = True
End Select
If bOk = False Then
fncNeuerName = Left(fncNeuerName, Len(fncNeuerName) - 1)
End If
Loop Until bOk = True
'Unzulässige/unerwünschte Zeichen im Datei-Namen ersetzen durch "_"
vZeichen = Array("\", "/", ":", "*", "?", """", "", "|")
For iI = LBound(vZeichen) To UBound(vZeichen)
fncNeuerName = VBA.Replace(fncNeuerName, vZeichen(iI), "_")
Next
fncNeuerName = fncNeuerName & ".mp3"
End Function