birleştirilmiş hücrede boş satırları silme

[spacebar]

değerli üstadlarım. A sutununda değişen bir metin formu var. buradaki birleştirilmiş satırlarda boş satırları nasıl kaldırabilirim. yardımcı olmanızı rica ederim. teşekkürler...

 

[ÖmerBey]

Merhaba,
Şöyle bir şey olur mu?
Sayfanın yedeğini alıp çalıştırınız...

With Range("A:A")
    .MergeCells = False
    .SpecialCells(xlCellTypeBlanks).Delete xlUp
    .WrapText = True
    .EntireRow.AutoFit
End With

 

[spacebar]

üstad ilginize teşekkür ederim. ancak bu kodlarda bütün paragrafı bir satır yapıyor. bu da uzun paragraflarda sorun yaratır. tek bir satır olduğu için sayfa yapısında sorun olur. benim yukarıdaki resimde 5-6-7-11-12-15. satırı yok edebilirse daha uygun olacak. tekrar teşekkür ederim.

 

[spacebar]

bir çözümü var mıdır bu sorunun.

 

[Ömer]

Merhaba,



Bu şekilde uygulamak yerine, birleştirilmiş hücreleri kaldırın aradaki boş satırları silin ve aşağıdaki kodları deneyin.

Sub deneme()
[A:A].WrapText = True
Cells.EntireRow.AutoFit
End Sub

Yeni fark ettim, Ömer Bey'de aynı metodu önermiş.

 

[spacebar]

evet üstad boşluğu kaldırıyor sorunu çözüyor ancak uzun metinlerde sayfa problemi yaşatacağı için çok uygun olmuyor. desteğiniz için teşekkür ederim.

 

[Korhan Ayhan]

Alternatif;

Verileriniz "Sheet1" isimli sayfada olsun. Dosyanızda birde "Sheet2" adında bir sayfa olsun.

Sonrasında kodu çalıştırıp deneyiniz.

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

 

[spacebar]

üstad teşekkür ederim. ellerinize sağlık.

 

[ÖmerBey]

Tecrübe, bilgiyi nasıl kullanacağını da bilmek olsa gerek...
Teşekkürler Korhan Ayhan.

 

[veyselemre]

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

 

[spacebar]

üstad mükemmel çalışıyor. ellerinize sağlık. teşekkür ederim.