DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Hocam belirli bir aralığın tamamında örnek.xlsm de her satırın değişiminde yükseklik ayarlamaktadır. Belirli bir aralıkta örneğin A1:A20 arasındaki tüm satırlarda aynı anda bu işlem yapılabilir mi?Örnek dosyayı deneyiniz.
Option Explicit
Sub Satir_Yuksekligi()
Dim S1 As Worksheet, Genislik As Integer, Yukseklik As Integer
Dim Alan As Range, Veri As Variant, Satir As Integer, X As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Test").Delete
On Error GoTo 0
Sheets.Add
Set S1 = ActiveSheet
S1.Name = "Test"
For Each Alan In Range("A1:A20")
Genislik = Range("A1").Columns.Width
Yukseklik = 0
Satir = 2
With S1
.Cells.Delete
.Cells.Font.Size = Alan.Font.Size
.Range("A1") = Alan.Text
.Range("A:A").WrapText = True
.Range("A1").VerticalAlignment = xlJustify
.Range("A1").ColumnWidth = Genislik / 5.3
.Range("A1").EntireRow.AutoFit
Veri = Split(.Range("A1"), Chr(10))
For X = 0 To UBound(Veri)
.Cells(Satir, 1) = Veri(X)
Yukseklik = Yukseklik + .Cells(Satir, 1).RowHeight
Satir = Satir + 1
Next
.Cells.Delete
End With
If Yukseklik = 0 Then Yukseklik = 15
Alan.RowHeight = Yukseklik
Next
On Error Resume Next
S1.Delete
On Error GoTo 0
Set S1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Satir_Yuksekligi()
Dim S1 As Worksheet, Genislik As Integer, Yukseklik As Integer
Dim Alan As Range, Veri As Variant, Satir As Integer, X As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Test").Delete
On Error GoTo 0
Sheets.Add
Set S1 = ActiveSheet
S1.Name = "Test"
For Each Alan In Range("D2:D6,D20:D24")
Genislik = Alan.Resize(, 4).Columns.Width
Yukseklik = 0
Satir = 2
With S1
.Cells.Delete
.Cells.Font.Size = Alan.Font.Size
.Range("A1") = Alan.Text
.Range("A:A").WrapText = True
.Range("A1").VerticalAlignment = xlJustify
.Range("A1").ColumnWidth = Genislik / 5.3
.Range("A1").EntireRow.AutoFit
Veri = Split(.Range("A1"), Chr(10))
For X = 0 To UBound(Veri)
.Cells(Satir, 1) = Veri(X)
Yukseklik = Yukseklik + .Cells(Satir, 1).RowHeight
Satir = Satir + 1
Next
.Cells.Delete
End With
If Yukseklik = 0 Then Yukseklik = 15
Alan.RowHeight = Yukseklik
Next
On Error Resume Next
S1.Delete
On Error GoTo 0
Set S1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub