Çözüldü Verileri Ayırmak İçin Nasıl Boşluk Ekleyebilirim?

[Rashoner]

Merhabalar yukarıdaki örnekteki gibi fatura numarası arttığında veya değiştiğinde araya boşluk koymak istiyorum. Elimdeki veriler binlerce satır olduğu için tek tek seçip yapmak çok zaman alıyor. Bunu kısa bir yöntemi var mıdır?

 

[zozotr]

Sub Ekle()
    Dim SonSatir As Long
    Dim i As Long
    
    SonSatir = Cells(Rows.Count, "B").End(xlUp).Row
    
    For i = SonSatir To 2 Step -1
        If Cells(i, "B").Value <> Cells(i - 1, "B").Value Then
            Rows(i).Insert
        End If
    Next i
End Sub

Merhaba, deneyin lütfen. Daha önce forumdan aldım bu kodu.
Modül olarak ekleyin. Çalıştırın. B Sütununda değer değiştiği anda alta boş satır atıyor

 

[Korhan Ayhan]

Merhaba,

Çok satırlı veri setiniz için makro kullanmanız daha sağlıklı olacaktır.

Option Explicit

Sub Insert_Row()
    Dim X As Long, Rng As Range, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Set Rng = Nothing
    Set Rng = Range("B:B").SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
    For X = Cells(Rows.Count, 2).End(3).Row To 3 Step -1
        If Cells(X, 2) <> Cells(X - 1, 2) Then Rows(X).Insert
    Next

    Application.ScreenUpdating = True

    MsgBox "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[Rashoner]

Sub Ekle()
    Dim SonSatir As Long
    Dim i As Long
   
    SonSatir = Cells(Rows.Count, "B").End(xlUp).Row
   
    For i = SonSatir To 2 Step -1
        If Cells(i, "B").Value <> Cells(i - 1, "B").Value Then
            Rows(i).Insert
        End If
    Next i
End Sub

Merhaba, deneyin lütfen. Daha önce forumdan aldım bu kodu.
Modül olarak ekleyin. Çalıştırın. B Sütununda değer değiştiği anda alta boş satır atıyor

Çok teşekkür ederim, denedim ve çalıştı.

 

[Rashoner]

Merhaba,

Çok satırlı veri setiniz için makro kullanmanız daha sağlıklı olacaktır.

Option Explicit

Sub Insert_Row()
    Dim X As Long
   
    Application.ScreenUpdating = False
   
    Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
    For X = Cells(Rows.Count, 2).End(3).Row To 3 Step -1
        If Cells(X, 2) <> Cells(X - 1, 2) Then Rows(X).Insert
    Next

    Application.ScreenUpdating = True

    MsgBox "Boş satır ekleme işlemi tamamlanmıştır.", vbInformation
End Sub

Bu kod da çalışıyor. Benim gibi ihtiyacı olan arkadaşlar varsa ikisini de kullanabilir. Yardımlarınız için çok teşekkürler.

 

[zozotr]

Çok teşekkür ederim, denedim ve çalıştı.

Kolay Gelsin
İyi çalışmalar

 

[HücrelereFısıldayanAdam]

Yalnızca, veriyi kolay okumak için değil, (Ctrl+Shift+alt ok ile kullanıldığında) büyük verileri konu bazında atlayarak kontrol etmek için çok yararlı.
Daha önce aklıma gelmemişti. Hepinize teşekkürler.

 

[Korhan Ayhan]

Önerdiğim kod ilk çalıştırıldığında eğer veri setinde aralarda boş satır yoksa hata veriyordu. Bu sebeple küçük bir düzeltme yaptım.

Ayrıca fiziksel satır eklemek yoğun satırlı verilerde zaman kaybına yol açacaktır. Bu sebeple aşağıdaki dizi yöntemi daha hızlı sonuç verecektir.

#3 nolu mesajda önerdiğim kod 10.000 satırlık veri setinde 35-40 saniye civarında işlemi tamamlıyor..

Aşağıdaki dizi yöntemi ise aynı işlem yaklaşık 0,35 saniye civarında tamamlıyor...

Option Explicit

Sub Insert_Row()
    Dim X As Long, Y As Integer, No As Long
    Dim My_Data As Variant, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    My_Data = Range("A2").Resize(Cells(Rows.Count, 1).End(3).Row, Cells(1, Columns.Count).End(1).Column).Value
    
    ReDim My_List(1 To Rows.Count, 1 To UBound(My_Data, 2))
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1) - 1
        If My_Data(X, 2) <> "" Then
            No = No + 1
            If My_Data(X, 2) <> My_Data(X + 1, 2) Then
                For Y = 1 To UBound(My_Data, 2)
                    My_List(No, Y) = My_Data(X, Y)
                Next
                No = No + 1
                For Y = 1 To UBound(My_Data, 2)
                    My_List(No, Y) = Empty
                Next
            Else
                For Y = 1 To UBound(My_Data, 2)
                    My_List(No, Y) = My_Data(X, Y)
                Next
            End If
        End If
    Next

    Range("A2").Resize(Rows.Count - 1, UBound(My_List, 2)).ClearContents
    Range("A2").Resize(No, UBound(My_List, 2)) = My_List
    
    Application.ScreenUpdating = True

    MsgBox "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[HücrelereFısıldayanAdam]

Korhan üstad veriyi diziye alarak kodu optimize etmiş, aşırı hızlı çalışıyor, gerçekten inanılmaz işe yarıyor.