Tabellennamen auf 31 Zeichen kürzen
12.12.2012 15:45:43
Jan
Klaus hatte mir schon super weitergeholfen (kann leider auf den alten Beitrag nicht mehr antworten) mit der Erstellung von neuen Excel-Files bzw. neuen Tabellenblättern (siehe unten). Dabei hat sich das Problem ergeben, dass die Namen teilweise über 31 Zeichen lang sind und daher das Makro abbricht.
Meine Lösung, den Tabellennamen zu kürzen, sah nun so aus, funktioniert aber nicht:
(das sind meine ersten VBA-Gehversuche, daher danke für jeden Tipp)
i = Len(rTables.Value)
rTables.Name = rTables.Value
If i > 31 Then rTables.Name = Left(rTables.Name, 31)
Am Besten wäre es sogar, wenn der Name bis zum ersten auftretenden Leerzeichen weggekürzt wird, maximal aber nach 31 Zeichen. Am ersten Teil (Leerzeichen) verzweifle ich aber völlig.
Sub MakeManyTables(iColNew As Integer)
Dim lRow As Long
Dim lAnzTable As Long
Dim wksOld As Worksheet
Dim i As Range
Set wksOld = ActiveSheet 'Blatt merken
Dim rTables As Range
lRow = Cells(Rows.Count, iColNew).End(xlUp).Row 'letzte Zeile
For Each rTables In Range(Cells(1, iColNew), Cells(lRow, iColNew))
If rTables.Value = "" Then
'nix! wenn leer dann nix!
Else 'aber sonst!
lAnzTable = Application.WorksheetFunction.CountIf(Cells(1, iColNew).EntireColumn, _
rTables.Value)
'so viele Datensätze dieses Names gibt es
Cells(rTables.Row, 1).Resize(lAnzTable, Columns.Count).Copy 'kopieren
Sheets.Add 'neues sheet
i = Len(rTables.Value)
rTables.Name = rTables.Value
If i > 31 Then rTables.Name = Left(rTables.Name, 31)
With ActiveSheet 'das neu erstellte sheet ist automatisch "active"!
.Name = rTables.Value 'sheet umbenennen
.Range("A2").PasteSpecial
.Range("A1").Value = "Überschrift 1" 'Überschriften wirst du brauchen?
.Range("B1").Value = "Überschrift 2" 'ändere sie hier!
.Range("C1").Value = "Überschrift 3" 'wenns mehr als vier Spalten werden,
.Range("D1").Value = "Überschrift 4" 'einfach fortsetzen bis der Artzt kommt. _
_
End With
wksOld.Activate 'zurück zum alten Blatt
Cells(rTables.Row, 1).Resize(lAnzTable, Columns.Count).ClearContents 'alten _
Datensatz löschen
End If
Next rTables
'* Dieser Block löscht die nun nicht mehr benötigten Tabellen 1, 2 und 3.
'* Das "DisplayAlerts" wird abgeschaltet, um das Fenster vom Excel
'* "da kann aber was in der Tabelle sein! Echt löschen?" zu verhindern
Application.DisplayAlerts = False
Sheets("Tabelle1").Delete
Sheets("Tabelle2").Delete
Sheets("Tabelle3").Delete
Application.DisplayAlerts = True
'* Block Tabellenlöschen Ende
End Sub