Bul ve Alt Satırları Alt Alta Ekle

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
678
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Merhaba.

Örnek dosyada eklemiş olduğum;
S1 sayfasında 3 adet satır var. Bu 3 satır 3 kişi anlamına geliyor.

S2 sayfasında da bu kişilerin TC numaralarına ait varisler var.
Her TC numara satırı 1 kişiye ait.

Burada yapılmak istenilen S1 K2'de bulunan TC yi S2 G sütununda arayacak.
Sayfada her kişi arasında 1 satır boşluk var. Yani aratılan TC blok olarak duran satırın ilk sırasında olsun.
Onu da SARI renk ile gösterdim. Sebebi alttaki diğer TC adresleri çok uzun sayfalarda mükerrer kişileri çağırır.

Dosya içinde örnek teşkil etmesi için sonuç diye bir sayfada ekledim.
Bu şekilde bir işlem yaptırılabilirmi?

Orjinal dosyalar daha fazla sütuna ve satıra sahip fakat KVKK sebebiyle gerçek verileri paylaşamıyorum.
İnanın binlerce taşınmaz maliki ve bunlara ait varisler var. Her hissedara tek tek bu işlemler yapılıyor.
Burdaki eklemiş olduğum örneğe göre ilerleteceğim. Teşekkür ederim.

 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,165
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.
Orijinal dosyanızda sayfa isimleri ve kolonları kendinize göre düzeltebilirsiniz. Gerekli alanlara not yazdım.
Eğer yapamazsanız orijinal dosyanız ile aynı özelliklere sahip örnek dosya ekleyin.

Kod:
Option Explicit

Sub Test()
    Dim syfMuris As Worksheet, syfMirasci As Worksheet, syfSonuc As Worksheet
    Dim BakMuris As Long
    Dim BakMirasci As Long
    Dim SaySonuc As Long
    Dim SayBirlestir As Long
    Dim BulMirasci As Range
    Application.DisplayAlerts = False
    Set syfMuris = Worksheets("S1")
    Set syfMirasci = Worksheets("S2")
    Set syfSonuc = Worksheets("Sonuç")
    syfSonuc.Range("A2:M" & Rows.Count).Clear
    SaySonuc = 2
    For BakMuris = SaySonuc To syfMuris.Cells(Rows.Count, "A").End(xlUp).Row
        If SaySonuc > 3 Then SaySonuc = SaySonuc + 1
        syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)  ' Muris sayfasından kopyalanan alanlar A:M arası
        Set BulMirasci = syfMirasci.Range("G:G").Find(what:=syfMuris.Cells(BakMuris, "K"), lookat:=xlWhole)
        If BulMirasci Is Nothing Then
            'Muris TC si Mirasçı sayfasında bulunamazsa ne olsun?
        Else
            For BakMirasci = BulMirasci.Row + 1 To Rows.Count
                If syfMirasci.Cells(BakMirasci, "B") = "" Then
                    syfMirasci.Range("B" & BulMirasci.Row & ":I" & BakMirasci - 1).Copy syfSonuc.Cells(SaySonuc, "F")   'Mirascı listesinden kopyalanan kolonlar B:I arası
                    SayBirlestir = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    syfSonuc.Range("A" & SaySonuc & ":A" & SayBirlestir - 1).Merge ' Hücreleri birleştir
                    syfSonuc.Range("B" & SaySonuc & ":B" & SayBirlestir - 1).Merge
                    syfSonuc.Range("C" & SaySonuc & ":C" & SayBirlestir - 1).Merge
                    syfSonuc.Range("D" & SaySonuc & ":D" & SayBirlestir - 1).Merge
                    syfSonuc.Range("H" & SaySonuc & ":H" & SayBirlestir - 1).Merge
                    syfSonuc.Range("E" & SaySonuc & ":E" & SayBirlestir - 1).Merge
                    syfSonuc.Range("I" & SaySonuc & ":I" & SayBirlestir - 1).Merge
                    SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    Exit For
                End If
               
            Next
        End If
    Next
    Application.DisplayAlerts = True
End Sub
 

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
678
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Merhaba.

Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.
Orijinal dosyanızda sayfa isimleri ve kolonları kendinize göre düzeltebilirsiniz. Gerekli alanlara not yazdım.
Eğer yapamazsanız orijinal dosyanız ile aynı özelliklere sahip örnek dosya ekleyin.

Kod:
Option Explicit

Sub Test()
    Dim syfMuris As Worksheet, syfMirasci As Worksheet, syfSonuc As Worksheet
    Dim BakMuris As Long
    Dim BakMirasci As Long
    Dim SaySonuc As Long
    Dim SayBirlestir As Long
    Dim BulMirasci As Range
    Application.DisplayAlerts = False
    Set syfMuris = Worksheets("S1")
    Set syfMirasci = Worksheets("S2")
    Set syfSonuc = Worksheets("Sonuç")
    syfSonuc.Range("A2:M" & Rows.Count).Clear
    SaySonuc = 2
    For BakMuris = SaySonuc To syfMuris.Cells(Rows.Count, "A").End(xlUp).Row
        If SaySonuc > 3 Then SaySonuc = SaySonuc + 1
        syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)  ' Muris sayfasından kopyalanan alanlar A:M arası
        Set BulMirasci = syfMirasci.Range("G:G").Find(what:=syfMuris.Cells(BakMuris, "K"), lookat:=xlWhole)
        If BulMirasci Is Nothing Then
            'Muris TC si Mirasçı sayfasında bulunamazsa ne olsun?
        Else
            For BakMirasci = BulMirasci.Row + 1 To Rows.Count
                If syfMirasci.Cells(BakMirasci, "B") = "" Then
                    syfMirasci.Range("B" & BulMirasci.Row & ":I" & BakMirasci - 1).Copy syfSonuc.Cells(SaySonuc, "F")   'Mirascı listesinden kopyalanan kolonlar B:I arası
                    SayBirlestir = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    syfSonuc.Range("A" & SaySonuc & ":A" & SayBirlestir - 1).Merge ' Hücreleri birleştir
                    syfSonuc.Range("B" & SaySonuc & ":B" & SayBirlestir - 1).Merge
                    syfSonuc.Range("C" & SaySonuc & ":C" & SayBirlestir - 1).Merge
                    syfSonuc.Range("D" & SaySonuc & ":D" & SayBirlestir - 1).Merge
                    syfSonuc.Range("H" & SaySonuc & ":H" & SayBirlestir - 1).Merge
                    syfSonuc.Range("E" & SaySonuc & ":E" & SayBirlestir - 1).Merge
                    syfSonuc.Range("I" & SaySonuc & ":I" & SayBirlestir - 1).Merge
                    SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    Exit For
                End If
              
            Next
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Muzaffer bey çok teşekkür ederim. Eklemiş olduğum örnekteki şekilde çalışıyor. Problem yok.
1. örnekte gözümden kaçan bir husus olmuş. Onuda örnek2 olarak ekledim.
TC bilgisi ulaşılamayan kısımlarda var. Onlarıda işlem yapılamayacak ama diğer listeye tabii edilebilirmi aynı sırada devam etmesi açısından.
Teşekkür ederim tekrardan.

 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,165
Excel Vers. ve Dili
2019 Türkçe
Kod:
Option Explicit

Sub Test()
    Dim syfMuris As Worksheet, syfMirasci As Worksheet, syfSonuc As Worksheet
    Dim BakMuris As Long
    Dim BakMirasci As Long
    Dim SaySonuc As Long
    Dim SayBirlestir As Long
    Dim BulMirasci As Range
    Application.DisplayAlerts = False
    Set syfMuris = Worksheets("S1")
    Set syfMirasci = Worksheets("S2")
    Set syfSonuc = Worksheets("Sonuç")
    syfSonuc.Range("A2:M" & Rows.Count).Clear
    SaySonuc = 2
    For BakMuris = SaySonuc To syfMuris.Cells(Rows.Count, "A").End(xlUp).Row
        If SaySonuc > 3 Then SaySonuc = SaySonuc + 1
        If syfMuris.Cells(BakMuris, "K") = "" Then
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc + 1)  ' TC Boş ise
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
            GoTo geç
        Else
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)  ' Muris sayfasından kopyalanan alanlar A:M arası
        End If
        
        
        Set BulMirasci = syfMirasci.Range("G:G").Find(what:=syfMuris.Cells(BakMuris, "K"), lookat:=xlWhole)
        If BulMirasci Is Nothing Then
            'Muris TC si Mirasçı sayfasında bulunamazsa ne olsun?
        Else
            For BakMirasci = BulMirasci.Row + 1 To Rows.Count
                If syfMirasci.Cells(BakMirasci, "B") = "" Then
                    syfMirasci.Range("B" & BulMirasci.Row & ":I" & BakMirasci - 1).Copy syfSonuc.Cells(SaySonuc, "F")   'Mirascı listesinden kopyalanan kolonlar B:I arası
                    SayBirlestir = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    syfSonuc.Range("A" & SaySonuc & ":A" & SayBirlestir - 1).Merge ' Hücreleri birleştir
                    syfSonuc.Range("B" & SaySonuc & ":B" & SayBirlestir - 1).Merge
                    syfSonuc.Range("C" & SaySonuc & ":C" & SayBirlestir - 1).Merge
                    syfSonuc.Range("D" & SaySonuc & ":D" & SayBirlestir - 1).Merge
                    syfSonuc.Range("H" & SaySonuc & ":H" & SayBirlestir - 1).Merge
                    syfSonuc.Range("E" & SaySonuc & ":E" & SayBirlestir - 1).Merge
                    syfSonuc.Range("I" & SaySonuc & ":I" & SayBirlestir - 1).Merge
                    SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    Exit For
                End If
            Next
        End If
geç:
    Next
    Application.DisplayAlerts = True
End Sub
 

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
678
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Kod:
Option Explicit

Sub Test()
    Dim syfMuris As Worksheet, syfMirasci As Worksheet, syfSonuc As Worksheet
    Dim BakMuris As Long
    Dim BakMirasci As Long
    Dim SaySonuc As Long
    Dim SayBirlestir As Long
    Dim BulMirasci As Range
    Application.DisplayAlerts = False
    Set syfMuris = Worksheets("S1")
    Set syfMirasci = Worksheets("S2")
    Set syfSonuc = Worksheets("Sonuç")
    syfSonuc.Range("A2:M" & Rows.Count).Clear
    SaySonuc = 2
    For BakMuris = SaySonuc To syfMuris.Cells(Rows.Count, "A").End(xlUp).Row
        If SaySonuc > 3 Then SaySonuc = SaySonuc + 1
        If syfMuris.Cells(BakMuris, "K") = "" Then
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc + 1)  ' TC Boş ise
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
            GoTo geç
        Else
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)  ' Muris sayfasından kopyalanan alanlar A:M arası
        End If
       
       
        Set BulMirasci = syfMirasci.Range("G:G").Find(what:=syfMuris.Cells(BakMuris, "K"), lookat:=xlWhole)
        If BulMirasci Is Nothing Then
            'Muris TC si Mirasçı sayfasında bulunamazsa ne olsun?
        Else
            For BakMirasci = BulMirasci.Row + 1 To Rows.Count
                If syfMirasci.Cells(BakMirasci, "B") = "" Then
                    syfMirasci.Range("B" & BulMirasci.Row & ":I" & BakMirasci - 1).Copy syfSonuc.Cells(SaySonuc, "F")   'Mirascı listesinden kopyalanan kolonlar B:I arası
                    SayBirlestir = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    syfSonuc.Range("A" & SaySonuc & ":A" & SayBirlestir - 1).Merge ' Hücreleri birleştir
                    syfSonuc.Range("B" & SaySonuc & ":B" & SayBirlestir - 1).Merge
                    syfSonuc.Range("C" & SaySonuc & ":C" & SayBirlestir - 1).Merge
                    syfSonuc.Range("D" & SaySonuc & ":D" & SayBirlestir - 1).Merge
                    syfSonuc.Range("H" & SaySonuc & ":H" & SayBirlestir - 1).Merge
                    syfSonuc.Range("E" & SaySonuc & ":E" & SayBirlestir - 1).Merge
                    syfSonuc.Range("I" & SaySonuc & ":I" & SayBirlestir - 1).Merge
                    SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    Exit For
                End If
            Next
        End If
geç:
    Next
    Application.DisplayAlerts = True
End Sub

Hocam teşekkür ederim diğer verilerde geliyor.
H ve I sütunundaki hata düzelebilir mi.
Aslında tek olan satırda çalışmış fakat bireşik olan satırda çalışmadı.


 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,165
Excel Vers. ve Dili
2019 Türkçe
Bu sefer oldu sanırım.

Kod:
Option Explicit

Sub Test()
    Dim syfMuris As Worksheet, syfMirasci As Worksheet, syfSonuc As Worksheet
    Dim BakMuris As Long
    Dim BakMirasci As Long
    Dim SaySonuc As Long
    Dim SayBirlestir As Long
    Dim BulMirasci As Range
    Application.DisplayAlerts = False
    Set syfMuris = Worksheets("S1")
    Set syfMirasci = Worksheets("S2")
    Set syfSonuc = Worksheets("Sonuç")
    syfSonuc.Range("A2:M" & Rows.Count).Clear
    SaySonuc = 2
    For BakMuris = SaySonuc To syfMuris.Cells(Rows.Count, "A").End(xlUp).Row
        If SaySonuc > 3 Then SaySonuc = SaySonuc + 1
        
        If syfMuris.Cells(BakMuris, "K") = "" Then
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)   ' TC Boş ise
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
            GoTo geç
        Else
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)  ' Muris sayfasından kopyalanan alanlar A:M arası
        End If
        Set BulMirasci = syfMirasci.Range("G:G").Find(what:=syfMuris.Cells(BakMuris, "K"), lookat:=xlWhole)
        If BulMirasci Is Nothing Then
            'Muris TC si Mirasçı sayfasında bulunamazsa ne olsun?
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
        ElseIf BulMirasci.Offset(1, 0) = "" Or BulMirasci.Offset(1, 0) = " " Then
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
        Else
            For BakMirasci = BulMirasci.Row + 1 To Rows.Count
                If syfMirasci.Cells(BakMirasci, "B") = "" Then
                    syfMirasci.Range("B" & BulMirasci.Row + 1 & ":I" & BakMirasci - 1).Copy syfSonuc.Cells(SaySonuc + 1, "F") 'Mirascı listesinden kopyalanan kolonlar B:I arası
                    SayBirlestir = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    syfSonuc.Range("A" & SaySonuc & ":A" & SayBirlestir - 1).Merge ' Hücreleri birleştir
                    syfSonuc.Range("B" & SaySonuc & ":B" & SayBirlestir - 1).Merge
                    syfSonuc.Range("C" & SaySonuc & ":C" & SayBirlestir - 1).Merge
                    syfSonuc.Range("D" & SaySonuc & ":D" & SayBirlestir - 1).Merge
                    syfSonuc.Range("H" & SaySonuc & ":H" & SayBirlestir - 1).Merge
                    syfSonuc.Range("E" & SaySonuc & ":E" & SayBirlestir - 1).Merge
                    syfSonuc.Range("I" & SaySonuc & ":I" & SayBirlestir - 1).Merge
                    With syfSonuc.Range("A" & SaySonuc & ":M" & SayBirlestir - 1)
                        .Borders(xlEdgeLeft).LineStyle = xlContinuous
                        .Borders(xlEdgeTop).LineStyle = xlContinuous
                        .Borders(xlEdgeBottom).LineStyle = xlContinuous
                        .Borders(xlEdgeRight).LineStyle = xlContinuous
                        .Borders(xlInsideVertical).LineStyle = xlContinuous
                        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    End With
                    SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    Exit For
                End If
            Next
        End If
geç:
    Next
    Application.DisplayAlerts = True
End Sub
 
Son düzenleme:

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
678
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Bu sefer oldu sanırım.

Kod:
Option Explicit

Sub Test()
    Dim syfMuris As Worksheet, syfMirasci As Worksheet, syfSonuc As Worksheet
    Dim BakMuris As Long
    Dim BakMirasci As Long
    Dim SaySonuc As Long
    Dim SayBirlestir As Long
    Dim BulMirasci As Range
    Application.DisplayAlerts = False
    Set syfMuris = Worksheets("S1")
    Set syfMirasci = Worksheets("S2")
    Set syfSonuc = Worksheets("Sonuç")
    syfSonuc.Range("A2:M" & Rows.Count).Clear
    SaySonuc = 2
    For BakMuris = SaySonuc To syfMuris.Cells(Rows.Count, "A").End(xlUp).Row
        If SaySonuc > 3 Then SaySonuc = SaySonuc + 1
       
        If syfMuris.Cells(BakMuris, "K") = "" Then
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)   ' TC Boş ise
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
            GoTo geç
        Else
            syfMuris.Range("A" & BakMuris & ":M" & BakMuris).Copy syfSonuc.Range("A" & SaySonuc)  ' Muris sayfasından kopyalanan alanlar A:M arası
        End If
        Set BulMirasci = syfMirasci.Range("G:G").Find(what:=syfMuris.Cells(BakMuris, "K"), lookat:=xlWhole)
        If BulMirasci Is Nothing Then
            'Muris TC si Mirasçı sayfasında bulunamazsa ne olsun?
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
        ElseIf BulMirasci.Offset(1, 0) = "" Or BulMirasci.Offset(1, 0) = " " Then
            SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
        Else
            For BakMirasci = BulMirasci.Row + 1 To Rows.Count
                If syfMirasci.Cells(BakMirasci, "B") = "" Then
                    syfMirasci.Range("B" & BulMirasci.Row + 1 & ":I" & BakMirasci - 1).Copy syfSonuc.Cells(SaySonuc + 1, "F") 'Mirascı listesinden kopyalanan kolonlar B:I arası
                    SayBirlestir = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    syfSonuc.Range("A" & SaySonuc & ":A" & SayBirlestir - 1).Merge ' Hücreleri birleştir
                    syfSonuc.Range("B" & SaySonuc & ":B" & SayBirlestir - 1).Merge
                    syfSonuc.Range("C" & SaySonuc & ":C" & SayBirlestir - 1).Merge
                    syfSonuc.Range("D" & SaySonuc & ":D" & SayBirlestir - 1).Merge
                    syfSonuc.Range("H" & SaySonuc & ":H" & SayBirlestir - 1).Merge
                    syfSonuc.Range("E" & SaySonuc & ":E" & SayBirlestir - 1).Merge
                    syfSonuc.Range("I" & SaySonuc & ":I" & SayBirlestir - 1).Merge
                    With syfSonuc.Range("A" & SaySonuc & ":M" & SayBirlestir - 1)
                        .Borders(xlEdgeLeft).LineStyle = xlContinuous
                        .Borders(xlEdgeTop).LineStyle = xlContinuous
                        .Borders(xlEdgeBottom).LineStyle = xlContinuous
                        .Borders(xlEdgeRight).LineStyle = xlContinuous
                        .Borders(xlInsideVertical).LineStyle = xlContinuous
                        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    End With
                    SaySonuc = syfSonuc.Cells(Rows.Count, "F").End(xlUp).Row + 1
                    Exit For
                End If
            Next
        End If
geç:
    Next
    Application.DisplayAlerts = True
End Sub

Çok teşekkür ederim. Mükemmel oldu. Yanımda asıl veriler yok haftaiçi dairede biraz şablonu ayarlamam lazım. Takıldığım yerde desteğinize ihtiyacım var.
 

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
678
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Merhaba konuyla ilgili ÖM attım. Bakma imkanınız varmıdır. Teşekkür ederim.
 
Üst