Zeilenhöhe verbundene Zellen
03.09.2014 11:34:11
DirkR
ich brauche eure Hilfe!
Folgendes Problem beschäftigt mich seit STUNDEN!!!
Ich möchte in einer Tabelle die Zeilenhöhe von verbundenen Zellen automatisch einstellen. Ich habe im Forum auch schon einiges gefunden aber leider nicht passend genug.
Ich möchte, wenn ich in der Tabelle Angebotstext, nur die Zeilen automatisch anpassen, in dennen in Spalte H ein x steht. in den meisten fällen ist der verbundene Bereich in den Spalten A:F, kann aber auch schon mal E:F sein. In den verbundenen Zellen sind Verkettungen, mal mehr mal weniger.
Ich möchte nun, dass er zeile für zeile durchgeht, und in den Zeilen mit dem x in Spalte H die Zeilenhöhe automatisch ermittelt. Das ganze soll bei dem Ereignis Worksheet_Activate ausgelöst werden.
Habe den folgenden Lösungsansatz aus dem Forum gefunden, den ich aber nur teilweisse umgebaut bekomme:
Option Explicit
' nach: www.herber.de/mailing/137101h.htm
' "Zeilenhöhe bei verbundenen Zellen anpassen"
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) > 1000 Then
MsgBox "Der Text in " & rngC.Address(0, 0) & " hat über 1000 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
End If
Next cc
Rows(lngZeileNr).RowHeight = sngHoehe ' max. optim. Höhe einstellen
Application.ScreenUpdating = True
End Sub Sub test()
ZeilenhoeheVerbundene 20
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, arrZ, colZ As New Collection, ii As Long
arrZ = Array(13, 20, 28, 15) ' 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
' eine der möglichen Alternativen:
'
Private Sub xWorksheet_Change(ByVal Target As Range)
Dim rng As Range, colZ As New Collection, ii As Long
For Each rng In Target ' falls mehrere Zellen auf einmal geändert
If (rng.Row >= 15 And rng.Row = 35 And rng.Row Er funktioniert nur dann, wenn die verbundene Zelle von A beginnt.
Private Sub Worksheet_Activate()
Dim I As Long
Dim ArrRows As String
ActiveSheet.DisplayPageBreaks = True
Application.ScreenUpdating = False
Rows("1:1200").EntireRow.Hidden = False
For I = 405 To 1200
If UCase(Cells(I, 7).Value) = "X" And _
Cells(I, 1).Value = "" Then Rows(I).Hidden = True
If UCase(Cells(I, 8).Value) = "X" Then ZeilenhoeheVerbundene I
Next I
Application.ScreenUpdating = True
End Sub
kann mir bitte jemand helfen?
Danke schon mal!!!
Gruß DirkR
Anzeige