İsim Gruplarının Yanına Satır Sayıları

[hakki83]

Değerli hocalarım iyi günler.

2 sorum var

Birinci sorum:
Örnek dosya1’de, A sütununda isim grupları vardır.
B sütununa, tam olarak örnekteki gibi satır sayılarını makroyla otomatik oluşturabilir miyiz?

İkinci sorum:
Örnek dosya1’deki isim gruplarının arasında düzensiz boşluklar vardır.
Aralarındaki boşluğu makroyla 1 boşluk olacak şekilde oluşturabilir miyiz? (Örnek dosya2’deki gibi olacak şekilde)


İkisi ayrı sorudur, teşekkürler.

 

[alicimri]

2. sorunun cevabı 10 rakamı afakidir.

Sub Makro2()
For i = 1 To 10
    Cells.Replace What:="  ", Replacement:=" "
    Next
End Sub

 

[hakki83]

2. sorunun cevabı 10 rakamı afakidir.

Sub Makro2()
For i = 1 To 10
    Cells.Replace What:="  ", Replacement:=" "
    Next
End Sub

Teşekkürler. Fakat düğmeye basınca bir şey olmadı.

 

[alicimri]

Nasıl yaptınız bilmiyorum ama basit bir kod hatasız çalışması gerek.
Manüel çözüm:
Giriş/Bul ve Seç/Değiştir
Sizde DEĞİŞTİR daha değişik bir yerden çıkabilir)
Çıkan iletişim Kutusunda;
Aranan: iki boşluk verin
Yeni Değer: bir boşluk verin.
Tümünü Değiştir'e 2-3 kere tıklayın
Not Dosyanızı indiremiyorum, yukardaki işlemde sonuç vermiyorsa, boşluk dedikleriniz, Tab ile filan yapılmış olabilir.

 

[hakki83]

Anladım. Bahsi geçen boşluk, satır boşluğu.
Yani A sütunundaki bazı hücrelerde veriler var.
Bu verilerin arasındaki boşlukların düzenli olabilmesi için 1’er boşluk olarak değişmesi gerekiyordu.

 

[Korhan Ayhan]

Alternatif;

2 sorunuz içinde aşağıdaki tek makroyu kullanabilirsiniz.

Option Explicit

Sub Grup_Say()
    Dim Veri As Range, X As Long, Alan As Range
    
    Range("B2:B" & Rows.Count).ClearContents
    
    For X = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If Cells(X, 1) = "" And Cells(X - 1, 1) = "" Then
            If Alan Is Nothing Then
                Set Alan = Cells(X, 1)
            Else
                Set Alan = Union(Alan, Cells(X, 1))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.EntireRow.Delete xlUp
    
    For Each Veri In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeConstants, 23).Areas
        Veri.Offset(, 1) = Veri.Count
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hakki83]

Alternatif;

2 sorunuz içinde aşağıdaki tek makroyu kullanabilirsiniz.

Option Explicit

Sub Grup_Say()
    Dim Veri As Range, X As Long, Alan As Range
   
    Range("B2:B" & Rows.Count).ClearContents
   
    For X = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If Cells(X, 1) = "" And Cells(X - 1, 1) = "" Then
            If Alan Is Nothing Then
                Set Alan = Cells(X, 1)
            Else
                Set Alan = Union(Alan, Cells(X, 1))
            End If
        End If
    Next
   
    If Not Alan Is Nothing Then Alan.EntireRow.Delete xlUp
   
    For Each Veri In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeConstants, 23).Areas
        Veri.Offset(, 1) = Veri.Count
    Next
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkürler hocam emeğinize sağlık