DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub Worksheet_Change(ByVal Target As Range)
[a1].RowHeight = Len([a1].Value)
End Sub
If Len(Madde) <= 120 Then GoTo DevamKapak
For i = 125 To Len(Madde) Step 120
For j = i To 1 Step -1
If Mid(Madde, j, 1) = " " Then
Madde = Left(Madde, j) & Chr(10) & Right(Madde, Len(Madde) - j)
i = j
Range("A" & MaddeYaz, "B" & MaddeYaz).RowHeight = Range("A" & MaddeYaz, "B" & MaddeYaz).RowHeight + 11
Exit For
End If
Next j
Next i
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [J53, B47]) Is Nothing Then Exit Sub
Rows(47).RowHeight = WorksheetFunction.RoundUp((Len(Range("B47")) / 90), 0) * 16
End SubOption Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, Genislik As Integer, Yukseklik As Integer
Dim Veri As Variant, Satir As Integer, X As Integer
If Intersect(Target, Range("A1:L" & Rows.Count)) Is Nothing Then Exit Sub
If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
Application.ScreenUpdating = False
Genislik = Range("A1:L1000").Columns.Width
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Test").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add
Set S1 = ActiveSheet
S1.Name = "Test"
Satir = 2
Application.DisplayAlerts = False
With S1
.Cells.Delete
.Cells.Font.Size = Target.Font.Size
.Range("A1") = Target.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
Target.RowHeight = Yukseklik
On Error Resume Next
Application.DisplayAlerts = False
S1.Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set S1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Satir_Yuksekliklerini_Ayarla()
Dim S1 As Worksheet, S2 As Worksheet, WF As WorksheetFunction
Dim Veri As Variant, Genislik As Integer, Yukseklik As Integer, Say As Byte
Dim X As Long, Y As Byte, Z As Integer, Son As Long, Satir As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set S1 = Sheets("Sözleşme Formülsüz")
Set WF = WorksheetFunction
On Error Resume Next
Sheets("Test").Delete
On Error GoTo 0
Sheets.Add
Set S2 = ActiveSheet
S2.Name = "Test"
Son = S1.Cells.Find(What:="*", SearchDirection:=xlPrevious).Row
For X = 1 To Son
ReDim Liste(1 To 12)
Yukseklik = 0
Satir = 2
Say = 0
For Y = 1 To 12
If S1.Cells(X, Y) <> "" Then
If S1.Cells(X, Y).MergeCells Then
Genislik = S1.Cells(X, Y).MergeArea.Columns.Width
Else
Genislik = S1.Cells(X, Y).Columns.Width
End If
With S2
.Cells.Delete
.Cells.Font.Size = S1.Cells(X, Y).Font.Size
.Range("A1") = S1.Cells(X, Y).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 Z = 0 To UBound(Veri)
.Cells(Satir, 1) = Veri(Z)
Yukseklik = Yukseklik + .Cells(Satir, 1).RowHeight
Satir = Satir + 1
Next
.Cells.Delete
End With
If Yukseklik = 0 Then Yukseklik = 15
Say = Say + 1
Liste(Say) = Yukseklik
End If
Next
If Say > 0 Then S1.Cells(X, Y).RowHeight = WF.Max(Yukseklik)
Next
On Error Resume Next
S2.Delete
On Error GoTo 0
Set WF = Nothing
Set S1 = Nothing
Set S2 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Satır yükseklikleri ayarlanmıştır.", vbInformation
End Sub