zeilenhöhe verbundenen Zellen von Zeile 1 bis 500

Bild

Betrifft: zeilenhöhe verbundenen Zellen von Zeile 1 bis 500
von: Marcel
Geschrieben am: 10.09.2015 15:39:15

Hallo Excel Gemeinde,
als erstes muss ich meinen großen Dank für Foren wie dieses aussprechen. Als bis dato passiver Leser der Beiträge konnte ich durch stümperhaftes zusammen schreiben eurer Codes jedes Problem lösen.
In einer Excel-Liste möchte ich nun, dass sich die Zeilenhöhe der verbundenen Zellen
automatisch an den Text anpasst. Nach intensiver Internetrecherche bin ich auch in diesem Forum _
auf folgenden Code gestoßen, der auch super funktioniert:


Sub AutoFitMergedCellRowHeight()
     Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
     Dim CurrCell As Range
     Dim ActiveCellWidth As Single, PossNewRowHeight As Single
     Dim iX As Integer
     If ActiveCell.MergeCells Then
        With ActiveCell.MergeArea
             If .Rows.Count = 1 And .WrapText = True Then
                 Application.ScreenUpdating = False
                 CurrentRowHeight = .RowHeight
                 ActiveCellWidth = ActiveCell.ColumnWidth
                 For Each CurrCell In Selection
                     MergedCellRgWidth = CurrCell.ColumnWidth + _
                        MergedCellRgWidth
                     iX = iX + 1
                 Next
                 MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
                 .MergeCells = False
                 .Cells(1).ColumnWidth = MergedCellRgWidth
                 .EntireRow.AutoFit
                 PossNewRowHeight = .RowHeight + 10
                 .Cells(1).ColumnWidth = ActiveCellWidth
                 .MergeCells = True
                 .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                  CurrentRowHeight, PossNewRowHeight)
             End If
         End With
     End If
     
     Range("A1").Select
 End Sub

Allerdings wird nur die gerade angewählte Zelle angepasst. Ich möchte dagegen, dass dieser Code für jede Zelle B "i" von i = 1 bis 500 durchläuft.
Meine amateurhaften Versuche das ganze einfach in eine For Schleife zu pressen haben natürlich nicht funktioniert.
Vielen Dank schonmal im Voraus!!

Bild

Betrifft: Schleife einfügen
von: Daniel
Geschrieben am: 10.09.2015 16:03:36
Hi

Sub AutoFitMergedCellRowHeight()
     Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
     Dim CurrCell As Range
     Dim ActiveCellWidth As Single, PossNewRowHeight As Single
     Dim iX As Integer
     Dim Zelle as Range
     
     For Each Zelle in Range("B1:B500").Cells
     
         If Zelle.MergeCells Then
             With Zelle.MergeArea
                
               hier dann der weitere Code 1:1 
               ggf jedes "ActiveCell" durch "Zelle" tauschen
              end with
         end If
     Next Zelle
End Sub
gruß Daniel

Bild

Betrifft: zeilenhöhe verbundenen Zellen
von: Rudi Maintaire
Geschrieben am: 10.09.2015 16:05:04
hallo,
teste mal:

Sub AutoFitMergedCellRowHeight()
  Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
  Dim CurrCell As Range
  Dim ActiveCellWidth As Single, PossNewRowHeight As Single
  Dim iX As Integer, lRow As Long
  For lRow = 1 To 500
    If Cells(lRow, 2).MergeCells Then
      With Cells(lRow, 2).MergeArea
        If .Rows.Count = 1 And .WrapText = True Then
          Application.ScreenUpdating = False
          CurrentRowHeight = .RowHeight
          ActiveCellWidth = Cells(lRow, 2).ColumnWidth
          For Each CurrCell In Selection
            MergedCellRgWidth = CurrCell.ColumnWidth + _
              MergedCellRgWidth
            iX = iX + 1
          Next
          MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
          .MergeCells = False
          .Cells(1).ColumnWidth = MergedCellRgWidth
          .EntireRow.AutoFit
          PossNewRowHeight = .RowHeight + 10
          .Cells(1).ColumnWidth = ActiveCellWidth
          .MergeCells = True
          .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
            CurrentRowHeight, PossNewRowHeight)
        End If
      End With
    End If
  Next lRow
  Range("A1").Select
End Sub
Gruß
Rudi

Bild

Betrifft: AW: zeilenhöhe verbundenen Zellen
von: Marcel
Geschrieben am: 10.09.2015 16:48:41
Zunächst vielen Dank an die schnellen Antworten!!
Mir kam dann doch noch ein EIGENER Einfall (stolz ;)).
Ich habe einfach ein zweites Makro geschrieben, dass das besagte Makro 500 mal ausführt:

Sub zeilenhoehemitmakro()
For i = 1 To 100
Range("B" & i).Activate
Call AutoFitMergedCellRowHeight
Range("E" & i).Activate
Call AutoFitMergedCellRowHeight
Next
End Sub

Sub AutoFitMergedCellRowHeight()
     Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
     Dim CurrCell As Range
     Dim ActiveCellWidth As Single, PossNewRowHeight As Single
     Dim iX As Integer
     If ActiveCell.MergeCells Then
        With ActiveCell.MergeArea
             If .Rows.Count = 1 And .WrapText = True Then
                 Application.ScreenUpdating = False
                 CurrentRowHeight = .RowHeight
                 ActiveCellWidth = ActiveCell.ColumnWidth
                 For Each CurrCell In Selection
                     MergedCellRgWidth = CurrCell.ColumnWidth + _
                        MergedCellRgWidth
                     iX = iX + 1
                 Next
                 MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
                 .MergeCells = False
                 .Cells(1).ColumnWidth = MergedCellRgWidth
                 .EntireRow.AutoFit
                 PossNewRowHeight = .RowHeight + 10
                 .Cells(1).ColumnWidth = ActiveCellWidth
                 .MergeCells = True
                 .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                  CurrentRowHeight, PossNewRowHeight)
             End If
         End With
     End If
    
 End Sub
Ich bin mir ziemlich sicher, dass eure Lösungen deutlich besser sind, aber mit meinen Makros agiere ich wie mit einem alten Auto: Solange es funktioniert lieber nicht rumfummeln.
LG

Bild

Betrifft: AW: zeilenhöhe verbundenen Zellen
von: Daniel
Geschrieben am: 10.09.2015 17:11:08
Hi
im Prinzp ne Super Idde.
die lässt sich aber noch deutlich verbessen, wenn du nicht mit der Aktiven Zelle arbeitest, sondern die Zelle, die bearbeitet werden soll, direkt ansprichst, ohne sie zu aktiveren.
damit dein Autofit-Makro funtkioniert, machst du ne Variablenübergabe:

Sub zeilenhoehemitmakro()
For i = 1 To 100
Call AutoFitMergedCellRowHeight(Cells(i, 2))
Call AutoFitMergedCellRowHeight(Cells(i, 2))
Next
End Sub

Sub AutoFitMergedCellRowHeight(Zelle as Range)
     Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
     Dim CurrCell As Range
     Dim ActiveCellWidth As Single, PossNewRowHeight As Single
     Dim iX As Integer
     If Zelle.MergeCells Then
        With Zelle.MergeArea
             If .Rows.Count = 1 And .WrapText = True Then
                 Application.ScreenUpdating = False
                 CurrentRowHeight = .RowHeight
                 ActiveCellWidth = ActiveCell.ColumnWidth
                 For Each CurrCell In Selection
                     MergedCellRgWidth = CurrCell.ColumnWidth + _
                        MergedCellRgWidth
                     iX = iX + 1
                 Next
                 MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
                 .MergeCells = False
                 .Cells(1).ColumnWidth = MergedCellRgWidth
                 .EntireRow.AutoFit
                 PossNewRowHeight = .RowHeight + 10
                 .Cells(1).ColumnWidth = ActiveCellWidth
                 .MergeCells = True
                 .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                  CurrentRowHeight, PossNewRowHeight)
             End If
         End With
     End If
    
 End Sub
Vorteil: Code wird kürzer, schneller und der Bildschirm zappelt nicht.
Gruß Daniel

 Bild

Beiträge aus den Excel-Beispielen zum Thema "zeilenhöhe verbundenen Zellen von Zeile 1 bis 500 "