Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Zellenhöhe automatisch anpassen bei verbundenen Spalten
#1
Information 
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:
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


Angehängte Dateien
.xlsm   Anpassung.xlsm (Größe: 41,57 KB / Downloads: 22)
Antworten Top
#2
Hallo,

ändere mal die Zuweisung der Zeilehöhe an die Variablen sngHoehe so ab

Code:
sngHoehe = Application.WorksheetFunction.Max(.Cells(1).RowHeight, .Cells(2).RowHeight)     ' Mindesthöhe (insbes. nicht-verbundene Zellen)
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#3
Hallo Steffl,

vielen Dank für deine Antwort! Bin erst jetzt zum ausprobieren gekommen und leider scheint es nicht zu klappen, oder es liegt an mir :29:

Ich habe mehrere Sachen durchgespielt:
1. Nur die Zeile
sngHoehe = .RowHeight
durch deine Zeile ersetzt
sngHoehe = Application.WorksheetFunction.Max(.Cells(1).RowHeight, .Cells(2).RowHeight)

2. Beide Zeilen
sngHoehe = .RowHeight
und
sngHoehe = Application.Max(sngHoehe, rngC.Height)
durch deine Zeile ersetzt
sngHoehe = Application.WorksheetFunction.Max(.Cells(1).RowHeight, .Cells(2).RowHeight)

3. Nur die Zeile
sngHoehe = Application.Max(sngHoehe, rngC.Height)
durch deine Zeile ersetzt
sngHoehe = Application.WorksheetFunction.Max(.Cells(1).RowHeight, .Cells(2).RowHeight)

Dann dachte ich mir diese Zeilen machen noch ein Problem
Code:
' ActiveSheet.Unprotect
        ' rngC.Select
        ' Selection.Locked = False
        ' ActiveSheet.Protect , _
        ' DrawingObjects:=True, _
        ' AllowFormattingCells:=True, _
        ' AllowFormattingColumns:=True, _
        ' AllowFormattingRows:=True

hab sie also auskommentiert, aber das hat leider auch nichts gebracht! Immer noch beeinflusst, dass anpassen der zweiten Spalte nicht die erste Spalte.

Es wäre wirklich sehr nett von dir, wenn du mir da noch einmal auf die Sprünge Helfen könntest!

Vielen vielen Dank
Der Mitch
Antworten Top
#4
Hallo Mitch,

tut mir leid. Da kann ich dir keine Lösung anbieten.
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#5
Hi,

ok macht nichts! Danke dir trotzdem sehr für deine Hilfe. Vielleicht weiß ja noch jemand anders Rat? Angel

Würde mich sehr freuen!!!!

viele Grüße,
Mitch
Antworten Top
#6
Hallo Mitch,

sind die verbundenen Zellen immer an gleicher Stelle: B4:Y4 und AA4:AW4 und noch einmal in Zeile 4 im gleichen Bereich?

Müssen die Spaltenbreiten immer neu angepasst werden?

Das Problm mit mehr als 3000 Zeichen aussen vor gelassen kannst Du das Problem mit der Zeilenhöhe so lösen:

sngMergWid = 0
For Each rngM In .Cells
sngMergWid = rngM.ColumnWidth + sngMergWid
Next


Die rote Zeile an gezeigter Stelle ergänzen.
Gruß Atilla
Antworten Top
#7
Hallo,

danke für deine Antwort. Das Problem mit den 3000 Zeichen ist auch erst einmal nicht so wichtig! Nun zu deinen Fragen.

Zitat:sind die verbundenen Zellen immer an gleicher Stelle: B4:Y4 und AA4:AW4 und noch einmal in Zeile 4 im gleichen Bereich?

Die Verbundenen Zeilen gehen immer von B4:Y4 und AA4:AW4! Es gibt aber noch mehrere Spalten, also nicht nur 4 und 10, sondern noch weitere in denen das geschehen soll! Wollte das im Beispiel nur etwas Runterbrechen.

Zitat:Müssen die Spaltenbreiten immer neu angepasst werden?

Das verstehe ich gerade nicht so recht. Die Spaltenbreiten sind ja quasi Fest und zwar von B4:Y4 und AA4:AW4 usw.

***************************************************************************
Ich habe deinen Code jetzt einmal übernommen! ES PASST!!!! Super, vielen vielen DANK!!!!!!
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

viele Grüße,
Mitch
Antworten Top
#8
Hall Mitch,

wenn die Spaltenbreite der verbundenen Zellen alle gleich sind, dann kann man die Breite der verbundenen Zelle errechnen, man braucht die Schleife nicht.
Auch in der äußeren Schleife kann man die Schleife schneller abarbeiten. Wenn eine Verbundene Zelle
gefunden wurde, braucht man nicht alle Spalten des Verbunds durchlaufen und prüfen ob sie verbunden sind. Man kann dann den Zähler cc um die Anzahl der verbundenen Spalten -1 erhöhen.

Schau mal:

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)
         lngSpalten = rngC.MergeArea.Columns.Count 'Anzahl der verbundenen Zellen
         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
               sngMergWid = sngMergWid + (.Count - 1) * 0.71
'               ' ----------------- Merge aufheben, Zellbreite auf Gesamtbreite
               .MergeCells = False
               rngC.ColumnWidth = (rngC.ColumnWidth * lngSpalten) + ((lngSpalten - 1) * 0.71) 'Gesamtbreite rechnen
               ' ---------------------------------- 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
         cc = cc + lngSpalten - 1
      End If
   Next cc
   Rows(lngZeileNr).RowHeight = sngHoehe         ' max. optim. Höhe einstellen
   Application.ScreenUpdating = True
End Sub
Gruß Atilla
Antworten Top
#9
Hallo Atilla,

Danke dir noch einmal sehr für deine Hilfe!!!

Ich habe deinen zweiten Vorschlag auch einmal umgesetzt und es Passt!!!

Am Rand noch einmal eine weitere Frage.

Wenn ich ein Array mit X Werten haben.

Z.B.
arrZ = Array(6, 8, 10, 16, 22, 28)

wie kann ich für alle Werte in diesen Array einmal +1 sagen?

Ich habe mir das so überlegt

arrZ = Array(6 + i, 8 + i, 10+ i, 16+ i, 22+ i, 28+ i)

i++

gibt es da nicht noch eine elegantere Möglichkeit?

viele Grüße
Mitch
Antworten Top
#10
Hallo,
wenn Du die Werte des Arrays um eins erhöhen möchtest, dann ginge es mit einer Schleife.
Nach folgendem Prinzip:

Sub test()
Dim arrZ, i As Long
arrZ = Array(6, 8, 10, 16, 22, 28)
For i = LBound(arrZ) To UBound(arrZ)
arrZ(i) = arrZ(i) + 1
Next i
MsgBox Join(arrZ, "; ") 'in der MsgBox werden die Werte vom Array durch Semikolon getrennt angezeigt
End Sub
Gruß Atilla
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste