Bul > Altına Ekle ve Kalanları Birleştir

RBozkurt · 22 Aralık 2021

İyi günler. Ekteki dosyada resimdeki hatayı veriyor. Dosyanın aslında bu hata yok. Düzenlemeye çalıştım olmadı.
Farklı bir versiyonu https://www.excel.web.tr/threads/bul-ve-alt-satirlari-alt-alta-ekle.198458/#post-1109954 konuda yapıldı ama oradada kısmen hata var ve kendim düzenleyemedim.

Dosyada en son sayfaya örnek ekledim o şekilde ayarlama konusunda yardımcı olabilirmisiniz?

ÖmerFaruk · 22 Aralık 2021

NetcadRapor sayfasının K sütunundaki mi L sütunundaki değeri mi arıyorsunuz?
Find işlevi sonuç üretemediği için hata veriyor.

......What:=Sayfa2.Cells(bb, "L") olması lazım gibi hissediyorum

RBozkurt · 22 Aralık 2021

ÖmerFaruk' Alıntı:
NetcadRapor sayfasının K sütunundaki mi L sütunundaki değeri mi arıyorsunuz?
Find işlevi sonuç üretemediği için hata veriyor.

......What:=Sayfa2.Cells(bb, "L") olması lazım gibi hissediyorum

Evet hocam L değerini arayacak. L yapınca da olmadı.

Uygulama şu şekilde
NetcadRapor'da L sütunundaki TC yi
MernisListe G sütununda arayacak ve değerleri ekleyecek.
İstenilen Sonuç Ekranı sayfasındaki gibi sonuçlanması lazım. Ben manuel oluşturdum örnek olarak.

Yukarıda ilk mesajımdaki konudada farklı bir makro ile kısmen yapıldı. Bu şekilde uyarlayamadım malesef.

Ömer · 22 Aralık 2021

Merhaba,

İlk mesajınıza istinaden yazmıştım. Deneyiniz.

Kod:

Sub tc_bul_yeni()

    Dim S1 As Worksheet, S2 As Worksheet
    Dim i As Long, c As Range, Adr As String

    Set S1 = Sheets("NetcadRapor")
    Set S2 = Sheets("MernisListe")
   
    S1.Range("F2:G60000,J2:K60000").ClearContents

    For i = 2 To S1.Cells(Rows.Count, "L").End(xlUp).Row
        If Len(S1.Cells(i, "L")) = 11 And IsNumeric(S1.Cells(i, "L")) = True Then
            Set c = S2.[G:G].Find(S1.Cells(i, "L"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    S1.Cells(i, "F") = S2.Cells(c.Row, "B")
                    S1.Cells(i, "G") = S2.Cells(c.Row, "C")
                    S1.Cells(i, "J") = S2.Cells(c.Row, "F")
                    S1.Cells(i, "K") = S2.Cells(c.Row, "G")
                    Set c = S2.[G:G].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End If
    Next i
       
End Sub

RBozkurt · 22 Aralık 2021

Ömer' Alıntı:

Merhaba,

İlk mesajınıza istinaden yazmıştım. Deneyiniz.

Kod:

Sub tc_bul_yeni()

    Dim S1 As Worksheet, S2 As Worksheet
    Dim i As Long, c As Range, Adr As String

    Set S1 = Sheets("NetcadRapor")
    Set S2 = Sheets("MernisListe")
  
    S1.Range("F2:G60000,J2:K60000").ClearContents

    For i = 2 To S1.Cells(Rows.Count, "L").End(xlUp).Row
        If Len(S1.Cells(i, "L")) = 11 And IsNumeric(S1.Cells(i, "L")) = True Then
            Set c = S2.[G:G].Find(S1.Cells(i, "L"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    S1.Cells(i, "F") = S2.Cells(c.Row, "B")
                    S1.Cells(i, "G") = S2.Cells(c.Row, "C")
                    S1.Cells(i, "J") = S2.Cells(c.Row, "F")
                    S1.Cells(i, "K") = S2.Cells(c.Row, "G")
                    Set c = S2.[G:G].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End If
    Next i
      
End Sub

Teşekkürler. Ben sütunları ayarlayım. Diğer 1. sayfadan çekilecek veriyide ekleyebilirmiyiz akabinde?
Hem çekecek hem birleştirme uygulayacak.

Ömer · 22 Aralık 2021

Yapmak istediğinizi detaylı açıklayınız.

RBozkurt · 22 Aralık 2021

Ömer' Alıntı:
Yapmak istediğinizi detaylı açıklayınız.

Öncelikle elimizde 2 adet elde edilmiş veri var.
1. NetcadRapor
2. MernisListe

1. listede olan her satır tapuda kayıtlı 1 kişiye ait.
2. listede ise TC'noya ait bilgiler var.
*Sağ ise tek satırdır, Ölü ise varisleri gözükür. Yani örnekteki 10000000055 TC sağ, 10000000066 TC ölü.

Bu kişiye ait TC sütunu dolu ise;
MernisListe G sütununda bu TC yi bulacak ve ÖnÇalışma sayfasına ekleyecek.

TC Sütunu boş, TC YOK yada 0 ise direk o bilgilerle ön çalışmaya aktaracak.

Yani varisler, 1. sayfadaki tapu malikinin altına eklenmiş olacak.

İşlem sonucunda ÖnÇalışma sayfası oluşacak. (İstenilen Sonuç Ekranı sayfası örnektir. Bu şekilde oldurmaya çalışıyorum.)

En son ada/parsel bazındada birleştirme düşüyorum ama bu kadar işlem içinde oda olur mu bilmiyorum.

Ömer · 22 Aralık 2021

Sorunuzu kısmen anladım, biraz zaman alabilir o yüzden akşam müsait olunca bakıp dönüş yapabilirim.

İlave bir soru: "MernisListe" sayfasına varis olup olmadığını yan sütunlara bilgi amaçlı eklenemiyor mu? Bu şekilde mi çözülmesi gerekiyor. Yani "MernisListe" sayfasına bilgileri girerken veri işlemesinin kolaylığı açısından yeni bilgiler eklenemiyor mu?

RBozkurt · 22 Aralık 2021

Ömer' Alıntı:
Sorunuzu kısmen anladım, biraz zaman alabilir o yüzden akşam müsait olunca bakıp dönüş yapabilirim.

İlave bir soru: "MernisListe" sayfasına varis olup olmadığını yan sütunlara bilgi amaçlı eklenemiyor mu? Bu şekilde mi çözülmesi gerekiyor. Yani "MernisListe" sayfasına bilgileri girerken veri işlemesinin kolaylığı açısından yeni bilgiler eklenemiyor mu?

Uygunsa gerçek veriyi özel mesaj atayım inceleyin. Normalde 1 satırsa tek kişi, 1den fazla satırsa varis vardır.

RBozkurt · 24 Aralık 2021

Konu ile ilgili bakabilme imkanınız oldu mu acaba?

Ömer · 27 Aralık 2021

İstediğiniz bu mu?
Sonuçlar doğruysa birleştirmeye sonra bakarız.

Kod:

Sub tc_bul_yeni()

    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim i As Long, c As Range, Adr As String, sat As Long, j As Long

    Set S1 = Sheets("NetcadRapor")
    Set S2 = Sheets("MernisListe")
    Set S3 = Sheets("ÖnÇalışma")
    son = S2.Cells(Rows.Count, "G").End(xlUp).Row
 
    Application.ScreenUpdating = False
    S3.Rows("2:" & Rows.Count).Clear
   
    sat = 2
    For i = 2 To S1.Cells(Rows.Count, "F").End(xlUp).Row
        Set c = S2.[G:G].Find(S1.Cells(i, "L"), , xlValues, xlWhole)
        If Not c Is Nothing And S1.Cells(i, "L") <> "" Then
            For j = c.Row To son
                If Len(S2.Cells(j, "G")) <> 11 Then
                    Exit For
                End If
                S3.Cells(sat, "C") = S1.Cells(i, "A")
                S3.Cells(sat, "D") = S1.Cells(i, "B")
                S3.Cells(sat, "E") = S1.Cells(i, "C")
                S3.Cells(sat, "H") = S2.Cells(j, "B")
                S3.Cells(sat, "I") = S2.Cells(j, "C")
                S3.Cells(sat, "F") = S1.Cells(i, "D")
                S3.Cells(sat, "G") = S1.Cells(i, "E")
                S3.Cells(sat, "J") = S1.Cells(i, "H")
                S3.Cells(sat, "K") = S1.Cells(i, "I")
                S3.Cells(sat, "L") = S1.Cells(i, "J")
                S3.Cells(sat, "M") = S1.Cells(i, "K")
                S3.Cells(sat, "T") = S1.Cells(i, "L")
                S3.Cells(sat, "U") = S2.Cells(j, "F")
                S3.Cells(sat, "V") = S2.Cells(j, "H")
                S3.Cells(sat, "W") = S2.Cells(j, "I")
                sat = sat + 1
            Next j
        Else
            S3.Cells(sat, "C") = S1.Cells(i, "A")
            S3.Cells(sat, "D") = S1.Cells(i, "B")
            S3.Cells(sat, "E") = S1.Cells(i, "C")
            S3.Cells(sat, "H") = S1.Cells(i, "F")
            S3.Cells(sat, "I") = S1.Cells(i, "G")
            S3.Cells(sat, "F") = S1.Cells(i, "D")
            S3.Cells(sat, "G") = S1.Cells(i, "E")
            S3.Cells(sat, "J") = S1.Cells(i, "H")
            S3.Cells(sat, "K") = S1.Cells(i, "I")
            S3.Cells(sat, "L") = S1.Cells(i, "J")
            S3.Cells(sat, "M") = S1.Cells(i, "K")
            S3.Cells(sat, "T") = S1.Cells(i, "L")
            sat = sat + 1
        End If
        sat = sat + 1
    Next i
   
    S3.Select
    MsgBox "Aktarım Tamamlandı.", vbInformation
    Application.ScreenUpdating = True
     
End Sub

RBozkurt · 27 Aralık 2021

@Ömer teşekkür ederim.
Ön çalışmada W sütununa S3.Cells(sat, "W") = S2.Cells(j, "I") ile durum bilgisini ekledim.

Tek eksiklik var.
TC bilgisi 0, boş yada TC YOK olan satırlarda Ad Soyad ve Baba Adı verisi gelmiyor.
Teşekkür ederim.

Ömer · 27 Aralık 2021

#11 numaralı mesajı güncelledim, deneyiniz.

RBozkurt · 27 Aralık 2021

Ömer' Alıntı:
#11 numaralı mesajı güncelledim, deneyiniz.

Eksiklik yok elinize sağlık @Ömer ustam.

Ömer · 27 Aralık 2021

Hücre birleştirme işlemi uygulanmıştır.

Kod:

Sub tc_bul_yeni()

    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim i As Long, c As Range, Adr As String, sat As Long, j As Long, s As Long, k As Integer

    Set S1 = Sheets("NetcadRapor")
    Set S2 = Sheets("MernisListe")
    Set S3 = Sheets("ÖnÇalışma")
    son = S2.Cells(Rows.Count, "G").End(xlUp).Row
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    S3.Rows("2:" & Rows.Count).Clear
  
    sat = 2
    For i = 2 To S1.Cells(Rows.Count, "F").End(xlUp).Row
        Set c = S2.[G:G].Find(S1.Cells(i, "L"), , xlValues, xlWhole)
        If Not c Is Nothing And S1.Cells(i, "L") <> "" Then
            For j = c.Row To son
                If s = 0 Then s = sat
                If Len(S2.Cells(j, "G")) <> 11 Then
                    Exit For
                End If
                S3.Cells(sat, "C") = S1.Cells(i, "A")
                S3.Cells(sat, "D") = S1.Cells(i, "B")
                S3.Cells(sat, "E") = S1.Cells(i, "C")
                S3.Cells(sat, "H") = S2.Cells(j, "B")
                S3.Cells(sat, "I") = S2.Cells(j, "C")
                S3.Cells(sat, "F") = S1.Cells(i, "D")
                S3.Cells(sat, "G") = S1.Cells(i, "E")
                S3.Cells(sat, "J") = S1.Cells(i, "H")
                S3.Cells(sat, "K") = S1.Cells(i, "I")
                S3.Cells(sat, "L") = S1.Cells(i, "J")
                S3.Cells(sat, "M") = S1.Cells(i, "K")
                S3.Cells(sat, "T") = S1.Cells(i, "L")
                S3.Cells(sat, "U") = S2.Cells(j, "F")
                S3.Cells(sat, "V") = S2.Cells(j, "H")
                S3.Cells(sat, "W") = S2.Cells(j, "I")
                sat = sat + 1
            Next j
            For k = 3 To 13
                If k < 8 Or k > 9 Then
                    S3.Cells(s, k).Resize(sat - s, 1).MergeCells = True
                    S3.Cells(s, k).Resize(sat - s, 1).VerticalAlignment = xlCenter
                End If
            Next k
            s = 0
        Else
            S3.Cells(sat, "C") = S1.Cells(i, "A")
            S3.Cells(sat, "D") = S1.Cells(i, "B")
            S3.Cells(sat, "E") = S1.Cells(i, "C")
            S3.Cells(sat, "H") = S1.Cells(i, "F")
            S3.Cells(sat, "I") = S1.Cells(i, "G")
            S3.Cells(sat, "F") = S1.Cells(i, "D")
            S3.Cells(sat, "G") = S1.Cells(i, "E")
            S3.Cells(sat, "J") = S1.Cells(i, "H")
            S3.Cells(sat, "K") = S1.Cells(i, "I")
            S3.Cells(sat, "L") = S1.Cells(i, "J")
            S3.Cells(sat, "M") = S1.Cells(i, "K")
            S3.Cells(sat, "T") = S1.Cells(i, "L")
            sat = sat + 1
        End If
        sat = sat + 1
    Next i
  
    S3.Select
    Range("A2:AD" & sat - 2).Borders.LineStyle = 1

    MsgBox "Aktarım Tamamlandı.", vbInformation
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

RBozkurt · 27 Aralık 2021

Ömer' Alıntı:

Hücre birleştirme işlemi uygulanmıştır.

Kod:

Sub tc_bul_yeni()

    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim i As Long, c As Range, Adr As String, sat As Long, j As Long, s As Long, k As Integer

    Set S1 = Sheets("NetcadRapor")
    Set S2 = Sheets("MernisListe")
    Set S3 = Sheets("ÖnÇalışma")
    son = S2.Cells(Rows.Count, "G").End(xlUp).Row

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    S3.Rows("2:" & Rows.Count).Clear
 
    sat = 2
    For i = 2 To S1.Cells(Rows.Count, "F").End(xlUp).Row
        Set c = S2.[G:G].Find(S1.Cells(i, "L"), , xlValues, xlWhole)
        If Not c Is Nothing And S1.Cells(i, "L") <> "" Then
            For j = c.Row To son
                If s = 0 Then s = sat
                If Len(S2.Cells(j, "G")) <> 11 Then
                    Exit For
                End If
                S3.Cells(sat, "C") = S1.Cells(i, "A")
                S3.Cells(sat, "D") = S1.Cells(i, "B")
                S3.Cells(sat, "E") = S1.Cells(i, "C")
                S3.Cells(sat, "H") = S2.Cells(j, "B")
                S3.Cells(sat, "I") = S2.Cells(j, "C")
                S3.Cells(sat, "F") = S1.Cells(i, "D")
                S3.Cells(sat, "G") = S1.Cells(i, "E")
                S3.Cells(sat, "J") = S1.Cells(i, "H")
                S3.Cells(sat, "K") = S1.Cells(i, "I")
                S3.Cells(sat, "L") = S1.Cells(i, "J")
                S3.Cells(sat, "M") = S1.Cells(i, "K")
                S3.Cells(sat, "T") = S1.Cells(i, "L")
                S3.Cells(sat, "U") = S2.Cells(j, "F")
                S3.Cells(sat, "V") = S2.Cells(j, "H")
                S3.Cells(sat, "W") = S2.Cells(j, "I")
                sat = sat + 1
            Next j
            For k = 3 To 13
                If k < 8 Or k > 9 Then
                    S3.Cells(s, k).Resize(sat - s, 1).MergeCells = True
                    S3.Cells(s, k).Resize(sat - s, 1).VerticalAlignment = xlCenter
                End If
            Next k
            s = 0
        Else
            S3.Cells(sat, "C") = S1.Cells(i, "A")
            S3.Cells(sat, "D") = S1.Cells(i, "B")
            S3.Cells(sat, "E") = S1.Cells(i, "C")
            S3.Cells(sat, "H") = S1.Cells(i, "F")
            S3.Cells(sat, "I") = S1.Cells(i, "G")
            S3.Cells(sat, "F") = S1.Cells(i, "D")
            S3.Cells(sat, "G") = S1.Cells(i, "E")
            S3.Cells(sat, "J") = S1.Cells(i, "H")
            S3.Cells(sat, "K") = S1.Cells(i, "I")
            S3.Cells(sat, "L") = S1.Cells(i, "J")
            S3.Cells(sat, "M") = S1.Cells(i, "K")
            S3.Cells(sat, "T") = S1.Cells(i, "L")
            sat = sat + 1
        End If
        sat = sat + 1
    Next i
 
    S3.Select
    Range("A2:AD" & sat - 2).Borders.LineStyle = 1

    MsgBox "Aktarım Tamamlandı.", vbInformation
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub

@Ömer ustam eline sağlık. Buda çalışıyor problem yok. Teşekkür ederim.

Ömer · 27 Aralık 2021

Rica ederim, iyi çalışmalar.

RBozkurt · 27 Aralık 2021

@Ömer ustam alttaki silme kodu dosyada da var aslında.

1. kodda içerik siliniyor ama biçimlendirme vs kalıyor. Hızlı temizliyor. Fakat 500 satır oluştuysa onlar kalıyor.
2. kod şeklinde yaparsam da aslında temiz oluyor ama "M1000000" dediğim için sayfaya 1000000 adet satır açıyor. Bu sefer dosya oluyor 30 40 mb.
Başka hangi makroyu deneyebilirim.

Kod:

Sub Temizle 1()
ThisWorkbook.Worksheets("MernisListe").Select
Range("A5:M1000000").ClearContents
Range("A5").Select
End Sub

Kod:

Sub Temizle 2()
ThisWorkbook.Worksheets("MernisListe").Select
Range("A5:M1000000").Delete
Range("A5").Select
End Sub

Ömer · 27 Aralık 2021

Deneyiniz.

Kod:

Sub Temizle1()
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    
    ThisWorkbook.Worksheets("MernisListe").Select
    Range("A5:M" & Rows.Count).Clear
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
End Sub

RBozkurt · 27 Aralık 2021

Ömer' Alıntı:

Deneyiniz.

Kod:

Sub Temizle1()
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
   
    ThisWorkbook.Worksheets("MernisListe").Select
    Range("A5:M" & Rows.Count).Clear
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
End Sub

Teşekkür ederim @Ömer ustam. Sağolun.

Bul > Altına Ekle ve Kalanları Birleştir

𐱅𐰇𐰼𐰚

Ekli dosyalar

Destek Ekibi

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚

Ekli dosyalar

Moderatör

𐱅𐰇𐰼𐰚

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚

Moderatör

𐱅𐰇𐰼𐰚