DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
[B][COLOR=Red]Sayfa1[/COLOR][/B]
Sayfa2
Private Sub CommandButton1_Click()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.ScreenUpdating = False
Sayfa1.Activate
Sayfa1.UsedRange.Rows.AutoFit
For Each i In Sayfa1.UsedRange
If i.MergeCells Then
i.Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, CurrentRowHeight, PossNewRowHeight)
End If
End With
Exit For
End If
Next i
Sayfa2.Activate
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("a1")) Is Nothing Then Exit Sub
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.ScreenUpdating = False
Sayfa1.Activate
Sayfa1.UsedRange.Rows.AutoFit
For Each i In Sayfa1.UsedRange
If i.MergeCells Then
i.Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, CurrentRowHeight, PossNewRowHeight)
End If
End With
Exit For
End If
Next i
Sayfa2.Activate
Application.ScreenUpdating = True
End Sub