AW: Hilfe bei Makro - String Liste benutzen
27.06.2008 14:00:19
fcs
Hallo Johannes,
mit 3 "einfachen" Befehlen ist es nicht getan. Insbesondere die Prüfung des Blattnamens (bestimmte Sonderzeichen dürfen nicht drin sein, Länge ist begrenzt) erfordert eine zusätzliche Prozedur, die fast so lang ist wie die Hauptprozedur.
Hier ein entsprechendes Makro. Die Kommentare sollten ausreichen, das du die notwendigen Anpassungen/Ergänzungen hinbekommst.
Das Makro muss du in einem allgemeinen Modul in der Datei einfügen, in der sich die Liste mit den Strings befindet.
Gruß
Franz
'Ersteller : fcs
'Erstellt : 2006-06-27
'Excelversion: 2003 SP2
Sub StringListe()
Dim wksListe As Worksheet, wksDaten As Worksheet, wbDaten As Workbook, wbHTML As Workbook
Dim objZelleString As Range
Dim Zeile As Long
Dim strBlattname As String
Set wksListe = ThisWorkbook.Worksheets("Liste") 'Tabellenblatt mit Stringliste
'Neue Mappe mit einem Tabellenblatt anlegen
Set wbDaten = Workbooks.Add(Template:=xlWBATWorksheet)
With wksListe
'Listenstrings abarbeiten in Spalte A ab Zeile 2
For Zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set objZelleString = .Cells(Zeile, 1)
'Prüfen ob HTM-Datei vorhanden
If Dir(objZelleString.Value) "" Then
'Datentabellenblatt setzen und ggf. zusätzliches Blatt einfügen
With wbDaten
If Zeile = 2 Then
Set wksDaten = .Worksheets(1)
Else
Set wksDaten = .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
End If
End With
'Tabellenblatt umbenennen
strBlattname = fncTabname(objWb:=wbDaten, strText:=objZelleString.Value, _
intAbschneiden:=3)
If strBlattname = "" Then
MsgBox "Blatt wurde nicht umbenannt! Da Namensprüfung/-änderung abgebrochen"
Else
wksDaten.Name = strBlattname
End If
'HTML-Datei schreibgeschützt öffnen
Set wbHTML = Workbooks.Open(Filename:=objZelleString.Value, ReadOnly:=True)
'Werte aus benutztem Datenbereich in neues Blatt kopieren
wbHTML.Worksheets(1).UsedRange.Copy
With wksDaten
'Einfügen der Werte ab Zelle A2
.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
'HTM-datei wieder schließen
wbHTML.Close savechanges:=False
'Listenstring in Zellen eintragen
.Cells(1, 1).Value = objZelleString.Value 'A1
.Cells(6, 1).Value = objZelleString.Value 'A6
'Tabelle Formatieren (beispiele)
.Cells.VerticalAlignment = xlVAlignTop 'Alle Zellen vertikal oben ausrichten
With .Columns(1)
.ColumnWidth = 30
.WrapText = True 'Zeileumbruch in den Zellen
End With
With .Columns(2)
.ColumnWidth = 20 'Spaltenbreiten
.NumberFormat = "#,##0.00" 'Zahlenformat
End With
.Columns(3).ColumnWidth = 15
.Cells(1, 1).Interior.ColorIndex = 6 'gelb
End With
Else
MsgBox "Datei zu Listeneintrag """ & objZelleString.Value & """ nichtgefunden!"
End If
Next
End With
Set wbDaten = Nothing: Set wbHTML = Nothing
Set wksListe = Nothing: Set wksDaten = Nothing
Set objZelleString = Nothing
End Sub
Function fncTabname(objWb As Workbook, strText As String, _
Optional strReplace As String = "_", _
Optional bolNurMuss As Boolean = False, _
Optional intAbschneiden As Integer = 3) As String
'objWb = Arbeitsmappe in der Tabellenblatt umbenannte werden soll
'strText = neuer Name des Tabellenblatts
'strReplace = Text durch den unzulässige Zeichen ersetzt werden, Vorgabe = "_"
'bolNurMuss = Wenn False, dann werden weitere Zeichen auch ersetzt. Vorgabe = False
'intAbschneiden = Vorgabe für das Abtrenne von Zeichen wenn Name zu lang (>30 Zeichen)
'1 = Zeichen werden links (am Anfang) abgetrennt
'2 = Zeichen werden rechts (am Ende) abgetrennt
'3 = Benutzer-Eingabe = Vorgabewert
'neuen Namen des Tabellenblatts prüfen
Dim strEingabe As String
Dim objBlatt As Object
Dim strName As String
strName = strText
If strName = "" Then
MsgBox "Leersting ist nicht zulässig als Blattname!"
Exit Function
End If
Eingabe:
'Ersetzen von nicht zulässigen Zeichen im Tabellenblattnamen
strName = Replace(strName, "/", strReplace, 1)
strName = Replace(strName, "\", strReplace, 1)
strName = Replace(strName, "[", strReplace, 1)
strName = Replace(strName, "]", strReplace, 1)
strName = Replace(strName, "*", strReplace, 1)
strName = Replace(strName, "?", strReplace, 1)
strName = Replace(strName, ":", strReplace, 1)
If bolNurMuss = False Then
'Ersetzen von Zeichen, die im Tabellenblattnamen nicht verwendet werden sollten
strName = Replace(strName, "!", strReplace, 1)
strName = Replace(strName, ";", strReplace, 1)
strName = Replace(strName, ",", strReplace, 1)
End If
'Prüfen ob Blattname länger 30 Zeichen
If Len(strName) > 30 Then
Select Case intAbschneiden
Case 1 ' Zeichen werden von links abgetrennt
strName = Right(strName, 30)
Case 2 ' Zeichen werden von rechts abgetrennt
strName = Left(strName, 30)
Case 3 ' Benutzereingabe
strEingabe = InputBox(Prompt:="Name ist zu lang (mehr als 30 Zeichen), bitte ändern" _
& vbLf & "Aktueller Name: " & strName _
& vbLf & "Länge : " & Len(strName) & "Zeichen", _
Title:="Tabellenname", Default:=strName)
If strEingabe = "" Then 'Abbrechen wurde gewählt
fncTabname = ""
Exit Function
Else
strName = strEingabe
GoTo Eingabe 'Syntax des eingegebenen Namens wird nochmals geprüft
End If
End Select
End If
'Prüfen, ob Name schon vorhanden
For Each objBlatt In objWb.Sheets
If objBlatt.Name = strName Then
strEingabe = InputBox(Prompt:="Name ist bereits vorhanden, bitte ändern" _
& vbLf & "Aktueller Name: " & strName, _
Title:="Tabellenname", Default:=strName)
If strEingabe = "" Then 'Abbrechen wurde gewählt
fncTabname = ""
Exit Function
Else
strName = strEingabe
GoTo Eingabe 'Syntax des eingegebenen Namens wird nochmals geprüft
End If
End If
Next
fncTabname = strName
End Function