Satır Genişliğini Otomatik Olarak Ayarlamak

[gagacan]

Satır genişliğini içindeki yazıya göre tüm çalışma kitabında otomatik olarak ayarlamak istiyorum. Elimde aşağıdaki gibi bir kod var ama sadece ilk gördüğü satırı autofit yapıyor. tüm sayfaya bu kodu nasıl uygulayabilirim ?

Kod:

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i


'Take a note of current active cell
Set StartCell = ActiveCell

'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c


Application.ScreenUpdating = False

'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
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

If MergedCellRgWidth > 255 Then
MergedCellRgWidth = 255
End If
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
MergedCellRgWidth = 0
Next i

StartCell.Select
Application.ScreenUpdating = True

'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing

End Sub

 

[sensizsoldum]

Merhaba, aşağıdaki kodları veriye göre genişletmek istediğiniz sayfalara ekleyin sayfaya her girişte, yapılan ve yapılan her işlem de hücre genişliklerini ayarlayacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
    Cells.EntireColumn.AutoFit
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.EntireColumn.AutoFit
End Sub

 

[turk-x]

Merhaba;
aşağıdaki aşağıdaki kod işinizi görür

Columns.EntireColumn.AutoFit

Sayın sensizsoldum benden önce cevaplamış konuyu açtıktan sonra biraz fazla oyalanmışım.

 

[gagacan]

Sensiz oldum ve turk-x çok teşekkürler. ancak her ikiside prıoblemimi çözmedi

 

[sensizsoldum]

Örnek dosya eklermisiniz?

 

[gagacan]

Ekli dosyayı görüntüle yüklenen.xls

Örnek dosya eklermisiniz?

Satır 86,88,90 ve belge uzadıkça tüm belgede autofit işlemi otomatik her açışta yada makro ile yapmasını istiyorum. Ekte örnek dosyayı gönderiyorum yardımlarınız için tekrar teşekkürler.

 

[sensizsoldum]

Merhaba,
Sayfanın KOD KISMINA aşağıdaki kodları uygulayın, bende sorunsuz bir şekilde çalışıyor. Modüle falan değil. Hücre geçişlerinde ya da farklı hücreler tıklandığında kod devreye girecektir.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.EntireColumn.AutoFit
End Sub

 

[gagacan]

Merhaba,
Sayfanın KOD KISMINA aşağıdaki kodları uygulayın, bende sorunsuz bir şekilde çalışıyor. Modüle falan değil. Hücre geçişlerinde ya da farklı hücreler tıklandığında kod devreye girecektir.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.EntireColumn.AutoFit
End Sub

Çalışan halini yüklermisiniz ?

 

[sensizsoldum]

Şirkette olduğumdan dosya upload edemiyorum. Sadece download edebilirim.

 

[gagacan]

Şirkette olduğumdan dosya upload edemiyorum. Sadece download edebilirim.

Teşekkürler

 

[gulvadi]

sadece birinci sayfada çalışır

 

[gagacan]

sadece birinci sayfada çalışır

Teşekkürler. elinize sağlık

 

[gagacan]

Sorun birleştirilmiş hücrelerden kaynaklanıyor. Birleştirlmiş hücre kullanmadığınızda kod başarılı cevap yazan herkese teşekkürler