AW: Unnú hatz ihm d'Sprache vaschlarn... ;-)
19.08.2009 18:21:39
fcs
Hallo Mark,
hier mal ein Ansatz, der die Teil-Texte in einen Hilfsbereich überträgt und dabei überwacht, ob sich die Zeilenhöhe ändert.
Diese Makro kopierst du im VBA-Editor in ein allgemeiens Modul deiner Persönlichen Makro Arbeitsmappe (PERSONL.XLS).
Jetzt kannst in Excel eine Symbolleiste-Anpassen oder besser auch neu Anlegen.
Menü Ansicht--Symbolleisten--Anpassen.
Im Dialog Register "Symbolleisten" wählen, Neu (name für Leiste eingeben) und Ok.
Im Dialog Register "Befehle" unter "Kategorie" "Makros" wählen. Dann unter "Befehle" "Benutzerdefinierte Schaltfläche" wählen und bei gedrückter linker Maustaste in die neue Symbolleiste ziehen.
Rechte-Maus-Klick auf neues Symbol und Makro zuweisen und ggf. weitere Einstellungen für den Button machen.
Anpassen-Dialog schließen.
Gruß
Franz
P.S.: Es kann sein, dass der Bereich der gedruckten Daten vorübergehend in Unordnung gerät - wenn kein Druckbereich fest definiert ist. Sollte aber nach Speichern und erneutem Öffnen der Datei wieder ok sein
Sub TextVerteilen()
'Verteilt selektierten text in darunter liegende Zeilen
Dim Bereich As Range, Zelle As Range
Dim strText As String, strTextNeu As String, strTextAlt
Dim arrText, lngWorte As Long, zeile As Long, Hoehe As Double
Dim wks As Worksheet
Set Bereich = Selection
If Bereich.Rows.Count > 1 Then
MsgBox "Bitte Zellen nur in einer Tabellenzeile selektieren!"
Exit Sub
End If
Set wks = ActiveSheet
strText = Bereich.Range("A1").Value
arrText = Split(strText, " ")
'Zelle in Spalte unterhalb der Tabellendaten festlegen
With wks
Set Zelle = .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row + 10, Bereich.Column)
End With
'Selektierte Zelle kopieren in Zelle
Bereich.Range("a1").Copy Zelle
Zelle.ClearContents
Hoehe = Zelle.EntireRow.RowHeight 'Referenzhöhe für zeile merken
'Zellenbereich so formatieren, dass Zeilenhöhe angepasst wird, wenn zuviel Text
With Zelle
With wks.Range(Zelle, .Offset(1, Bereich.Columns.Count - 1))
.HorizontalAlignment = xlHAlignCenterAcrossSelection
.WrapText = True
End With
.Offset(0, Bereich.Columns.Count).WrapText = False
End With
zeile = 0
'gemerkte texte aus Array einlesen
For lngWorte = LBound(arrText) To UBound(arrText)
strTextNeu = strTextAlt & IIf(strTextAlt = "", "", " ") & arrText(lngWorte)
Zelle.Value = strTextNeu
'Zellhöhe prüfen
If Zelle.EntireRow.RowHeight > Hoehe Then
If zeile > 0 Then
'Format aus selektierter Zelle in folgezeile kopieren
Bereich.Copy
Bereich.Range("A1").Offset(zeile, 0).PasteSpecial Paste:=xlPasteFormats
End If
'Teiltext eintragen
Bereich.Range("A1").Offset(zeile, 0).Value = strTextAlt
'Vorgaben für nächste zeile setzen
strTextAlt = arrText(lngWorte)
zeile = zeile + 1
'Prüfen, ob letztes Wort eingelesen wurde
ElseIf lngWorte = UBound(arrText) Then
If zeile > 0 Then
'Format aus selektierter Zelle in folgezeile kopieren
Bereich.Copy
Bereich.Range("A1").Offset(zeile, 0).PasteSpecial Paste:=xlPasteFormats
End If
'Resttext eintragen
Bereich.Range("A1").Offset(zeile, 0).Value = strTextNeu
Else
strTextAlt = strTextNeu
End If
Next
'Prüf-/Testzellen wieder löschen
Zelle.Clear
Zelle.EntireRow.Delete
End Sub
