16.01.2015, 18:12
Hallo,
ich bin neu hier und hoffe ihr könnt mir bei meinem Excel-VBA-Problem weiterhelfen.
Ich versuche es hier einmal möglichst gut zu beschreiben.
In meiner Tabelle (siehe Anhang) existieren zwei Textfelder nebeneinander (Spalte A und Spalte B). Wird das linke Feld ausgefüllt, funktioniert die Anpassung korrekt. (Siehe Code und Anhang). Wird als nächstes jedoch das rechte Feld ausgefüllt und wird hier mehr Text eingegeben als im linken Feld, findet keine automatische Anpassung statt. Das rechte Feld bleibt genauso groß wie das linke, unabhängig davon, wie viel man dort reinschreibt.
Dann habe ich noch ein zweites Problem, welches die festgelegte Höhe der Zeilen betrifft
Die Texteingabe in ein Feld ist aktuell auf 3000 Zeichen begrenzt. Der Grund dafür ist die limitierte Höhe einer Zelle (409 pt). Idealerweise soll aber unendlich viel Text eingegeben werden können. Meine erste Idee dazu war die folgende: Wenn mehr als 3000 Zeichen eingegeben wurden, füge eine neue Zeile darunter ein, verbinde sie mit der beschriebenen und mache die automatische Höhenanpassung für diese Zeile nochmal. Ich habe aber keine Ahnung, ob das so funktioniert.
Hier einmal der Code für die Tabelle:
Code Höhe automatisch anpassen:
vielen vielen Dank für eure Hilfe und ein schönes Wochenende
der Mitch
ich bin neu hier und hoffe ihr könnt mir bei meinem Excel-VBA-Problem weiterhelfen.
Ich versuche es hier einmal möglichst gut zu beschreiben.
In meiner Tabelle (siehe Anhang) existieren zwei Textfelder nebeneinander (Spalte A und Spalte B). Wird das linke Feld ausgefüllt, funktioniert die Anpassung korrekt. (Siehe Code und Anhang). Wird als nächstes jedoch das rechte Feld ausgefüllt und wird hier mehr Text eingegeben als im linken Feld, findet keine automatische Anpassung statt. Das rechte Feld bleibt genauso groß wie das linke, unabhängig davon, wie viel man dort reinschreibt.
Dann habe ich noch ein zweites Problem, welches die festgelegte Höhe der Zeilen betrifft
Die Texteingabe in ein Feld ist aktuell auf 3000 Zeichen begrenzt. Der Grund dafür ist die limitierte Höhe einer Zelle (409 pt). Idealerweise soll aber unendlich viel Text eingegeben werden können. Meine erste Idee dazu war die folgende: Wenn mehr als 3000 Zeichen eingegeben wurden, füge eine neue Zeile darunter ein, verbinde sie mit der beschriebenen und mache die automatische Höhenanpassung für diese Zeile nochmal. Ich habe aber keine Ahnung, ob das so funktioniert.
Hier einmal der Code für die Tabelle:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, arrZ, colZ As New Collection, ii As Long
arrZ = Array(4, 10) ' Nummern der überwachten Zeilen anpassen
For Each rng In Target ' falls mehrere Zellen auf einmal geändert
If Not IsError(Application.Match(rng.Row, arrZ, 0)) Then
On Error Resume Next
colZ.Add rng.Row, CStr(rng.Row) ' hier werden Dubletten vermieden
On Error GoTo 0
End If
Next rng
For ii = 1 To colZ.Count
ZeilenhoeheVerbundene colZ(ii) ' Höhen der gesammelten Zeilen optimieren
Next ii
Set colZ = New Collection
End Sub
Code Höhe automatisch anpassen:
Code:
Sub ZeilenhoeheVerbundene(lngZeileNr As Long)
' Parameter ist die Zeilennummer.
' In einer Zeile kann es mehrere verbundene Zellen geben.
Dim sngHoehe As Single, cc As Integer, rngC As Range
Dim sngActWid As Single, rngM As Range, sngMergWid As Single
Application.ScreenUpdating = False
With Rows(lngZeileNr)
.AutoFit
sngHoehe = .RowHeight ' Mindesthöhe (insbes. nicht-verbundene Zellen)
End With
For cc = 1 To Cells(lngZeileNr, Columns.Count).End(xlToLeft).Column
If Cells(lngZeileNr, cc) > "" And Cells(lngZeileNr, cc).MergeCells Then
Set rngC = Cells(lngZeileNr, cc)
If Len(rngC) > 3000 Then
MsgBox "Der Text in " & rngC.Address(0, 0) & " hat über 3000 Zeichen !" _
& vbLf & vbLf & "Bitte kürzen!", vbCritical, "ZeilenhoeheVerbundene"
rngC.Select
Exit Sub
End If
With rngC.MergeArea
If .Cells(1).Address = rngC.Address And .WrapText = True Then
sngActWid = rngC.ColumnWidth ' Merken zum Wiederherstellen
' ---------------------------------------- Gesamtbreite rechnen
For Each rngM In .Cells
sngMergWid = rngM.ColumnWidth + sngMergWid
Next
sngMergWid = sngMergWid + (.Count - 1) * 0.71
' ----------------- Merge aufheben, Zellbreite auf Gesamtbreite
.MergeCells = False
rngC.ColumnWidth = sngMergWid
' ---------------------------------- max. optim. Höhe ermitteln
.EntireRow.AutoFit
sngHoehe = Application.Max(sngHoehe, rngC.Height)
' --------------------------- Breite und Merge wiederherstellen
rngC.ColumnWidth = sngActWid
.MergeCells = True
End If
End With
ActiveSheet.Unprotect
rngC.Select
Selection.Locked = False
ActiveSheet.Protect , _
DrawingObjects:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True
End If
Next cc
Rows(lngZeileNr).RowHeight = sngHoehe ' max. optim. Höhe einstellen
Application.ScreenUpdating = True
End Sub
vielen vielen Dank für eure Hilfe und ein schönes Wochenende
der Mitch