- Katılım
- 2 Temmuz 2009
- Mesajlar
- 542
- Excel Vers. ve Dili
- office 2019 Türkçe
- Altın Üyelik Bitiş Tarihi
- 28/12/2022
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
With Range("A:A")
.MergeCells = False
.SpecialCells(xlCellTypeBlanks).Delete xlUp
.WrapText = True
.EntireRow.AutoFit
End With
Option Explicit
Sub Birlestirilmis_Alanda_Bos_Satirlari_Sil()
Dim S1 As Worksheet, S2 As Worksheet, Genislik As Double, Metin As Variant
Dim Yukseklik As Double, Veri As Range, X As Long, Satir As Long, Son As Long
Dim Hucre As Range, Toplam_Yukseklik As Double, Silinecek_Satir As Range
Application.ScreenUpdating = False
Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
Genislik = S1.Range("A1").Columns.Width
Satir = 2
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
For Each Veri In S1.Range("A1:A" & Son)
If Veri.Value <> "" Then
With S2
.Cells.Delete
.Cells.Font.Size = Veri.Font.Size
.Cells.RowHeight = Veri.RowHeight
.Range("A1") = Veri.Text
.Range("A:A").WrapText = True
.Range("A1").VerticalAlignment = xlJustify
.Range("A1").ColumnWidth = Genislik / 5.3
.Range("A1").EntireRow.AutoFit
Yukseklik = .Range("A1").RowHeight + .Range("A2").RowHeight
End With
If Veri.MergeCells = True Then
Toplam_Yukseklik = 0
For Each Hucre In Veri.MergeArea
Toplam_Yukseklik = Toplam_Yukseklik + Hucre.RowHeight
If Toplam_Yukseklik > Yukseklik Then
If Silinecek_Satir Is Nothing Then
Set Silinecek_Satir = Hucre
Else
Set Silinecek_Satir = Union(Silinecek_Satir, Hucre)
End If
End If
Next
End If
End If
Next
If Not Silinecek_Satir Is Nothing Then
S1.Select
Silinecek_Satir.EntireRow.Delete
End If
Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
MsgBox "Boş satırlar silinmiştir.", vbInformation
End Sub
Sub test()
Columns(1).MergeCells = False
yuk = Range("A1").EntireRow.RowHeight
Columns(1).EntireRow.AutoFit
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = Cells(Rows.Count, 1).End(3).Row To 1 Step -1
ekle = Int(Cells(i, 1).RowHeight / yuk)
Range(i + 1 & ":" & i + ekle).Insert Shift:=xlDown
Cells(i, 1).Resize(ekle + 1).MergeCells = True
Next
End Sub