Soru İkinci Sayfaya Veri Çekme Hakkında

[RBozkurt]

İyi günler.
Hayali veriler ile oluşturduğum bir excel çalışma kitabı ekliyorum. İçerisinde 2 sayfa bulunmaktadır.

Burda istenilen;
MernisRapor sayfasındaki verileri Liste sayfasına sıralamaktır.
Bu konuda yardımcı olabilirmisiniz?

https://dosyam.org/9up/%C3%96rnek_Veri.xlsx

 

[muratboz06]

Linkteki çalışma işinizi görecektir. Mernis listesiniz hep aynı formatta olmalıdır.

Bilgi

Bilgi

dosyam.org

 

[kulomer46]

Merhaba

Alternatif Çözüm EK 'tedir.

Bilgi

Bilgi

dosyam.org

 

[RBozkurt]

@muratboz06 ve @kulomer46 ikinizdede ayrı ayrı çok teşekkür ederim. Büyük bir yükten kurtardınız.
Sağlıcakla kalın.

 

[kulomer46]

@muratboz06 ve @kulomer46 ikinizdede ayrı ayrı çok teşekkür ederim. Büyük bir yükten kurtardınız.
Sağlıcakla kalın.

Selamlar...

 

[RBozkurt]

İyi günler tekrardan,
Ufak bir detayı unutmuşum. Örnek listeyi açınca A1 ve A12de görüldüğü üzere "MERNİS VARİS LİSTESİ" başlığı var.

Şöyle tarif edeyim. Elimde mesela 100 adet bu türde excel var. Ben birleştirme makrosu ile bunları 1 excele birleştiriyorum.
Her dosyanın başlığı "MERNİS VARİS LİSTESİ" şeklinde yani.

Vermiş olduğum örnek 2 dosya birleşmiş gibi.
Liste kısmında resimdeki gibi yada benzer mantıkta ayrılabilme imkanı varmıdır.
Boşluk gibi ayrılması yeterli yazı yazmasada olur.

 

[muratboz06]

Yukarıda sizinle paylaşmış olduğum excel dosyasında modul1 de yer alan kodu aşağıdaki ile değiştiriniz.

Sub ListeOluştur()
    Dim sonSatirKaynak As Integer
    Dim sonSatirHedef As Integer
    Dim kaynak As Worksheet
    Set kaynak = ThisWorkbook.Worksheets("MernisRapor")
    sonSatirKaynak = kaynak.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
    Dim hedef As Worksheet
    Set hedef = ThisWorkbook.Worksheets("Liste")
    
    Dim i As Integer
    For i = 1 To sonSatirKaynak
        If InStr(kaynak.Cells(i, 1).Value, "TC Kimlik") Then
        If InStr(kaynak.Cells(i - 2, 1).Value, "MERNİS VARİS LİSTESİ") Then
            sonSatirHedef = hedef.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
            hedef.Cells(sonSatirHedef, 7).Value = " "        ' Mernis Varis Listesi Boşluk bırakıldı.
        End If
            sonSatirHedef = hedef.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
            hedef.Cells(sonSatirHedef, 2).Value = kaynak.Cells(i + 1, 2).Value & " " & kaynak.Cells(i + 1, 4).Value        'isim soyisim
            hedef.Cells(sonSatirHedef, 3).Value = kaynak.Cells(i + 1, 6).Value        'Baba adı
            hedef.Cells(sonSatirHedef, 4).Value = kaynak.Cells(i + 1, 8).Value        'Anne adı
            hedef.Cells(sonSatirHedef, 5).Value = kaynak.Cells(i + 2, 6).Value        'Doğum yeri
            hedef.Cells(sonSatirHedef, 6).Value = kaynak.Cells(i + 2, 4).Value        'Doğum yılı
            hedef.Cells(sonSatirHedef, 7).Value = kaynak.Cells(i, 2).Value           'TC No
            hedef.Cells(sonSatirHedef, 8).Value = kaynak.Cells(i + 3, 2).Value        'Adres
        End If
    Next i
    
    Dim j As Integer
    j = 0
    For i = 2 To sonSatirHedef
    If hedef.Cells(i, 2) <> "" Then
        hedef.Cells(i, 1) = j + 1
        j = j + 1
    End If
    Next i
    
    hedef.Select
    MsgBox "İşleminiz tamamlandı."
    
End Sub

 

[RBozkurt]

@muratboz06 hocam elinize sağlık. Problemsiz çalışmaktadır.
Kişi bilgisinin bir üst satırında o kişiye ait Ölüm, Vatandaşlıktan Çıkma ve Açık şeklinde bilgi bulunmaktadır (A13 A18 A23 gibi.)

Şuan tüm veriyi çekiyor problemsiz olarak.
Adres satırına kişi bilgisi ÖLÜM ise ÖLÜ
Adres satırına kişi bilgisi Vatandaşlıktan Çıkma ise Vatandaşlıktan Çıkma
Adres satırına kişi bilgisi Açık ise şuanki çalıştığı şekilde mevcutta yazan adresi eklenebilirmidir?

https://dosyam.org/720/%C3%96rnek_Veri.xlsx

 

[muratboz06]

Deneyiniz.

Sub ListeOluştur()
    Dim sonSatirKaynak As Integer
    Dim sonSatirHedef As Integer
    Dim kaynak As Worksheet
    Set kaynak = ThisWorkbook.Worksheets("MernisRapor")
    sonSatirKaynak = kaynak.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
    Dim hedef As Worksheet
    Set hedef = ThisWorkbook.Worksheets("Liste")
    
    Dim i As Integer
    For i = 1 To sonSatirKaynak
        If InStr(kaynak.Cells(i, 1).Value, "TC Kimlik") Then
        If InStr(kaynak.Cells(i - 2, 1).Value, "MERNİS VARİS LİSTESİ") Then
            sonSatirHedef = hedef.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
            hedef.Cells(sonSatirHedef, 7).Value = " "        ' Mernis Varis Listesi Boşluk bırakıldı.
        End If
            sonSatirHedef = hedef.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
            hedef.Cells(sonSatirHedef, 2).Value = kaynak.Cells(i + 1, 2).Value & " " & kaynak.Cells(i + 1, 4).Value        'isim soyisim
            hedef.Cells(sonSatirHedef, 3).Value = kaynak.Cells(i + 1, 6).Value        'Baba adı
            hedef.Cells(sonSatirHedef, 4).Value = kaynak.Cells(i + 1, 8).Value        'Anne adı
            hedef.Cells(sonSatirHedef, 5).Value = kaynak.Cells(i + 2, 6).Value        'Doğum yeri
            hedef.Cells(sonSatirHedef, 6).Value = kaynak.Cells(i + 2, 4).Value        'Doğum yılı
            hedef.Cells(sonSatirHedef, 7).Value = kaynak.Cells(i, 2).Value           'TC No
            hedef.Cells(sonSatirHedef, 8).Value = Mid(kaynak.Cells(i - 1, 1).Value, 21, InStr(1, kaynak.Cells(i - 1, 1).Value, ")", vbBinaryCompare) - 21)
            hedef.Cells(sonSatirHedef, 9).Value = kaynak.Cells(i + 3, 2).Value 'Adres bir sonraki sütuna taşındı
            
        End If
    Next i
    
    Dim j As Integer
    j = 0
    For i = 2 To sonSatirHedef
    If hedef.Cells(i, 2) <> "" Then
        hedef.Cells(i, 1) = j + 1
        j = j + 1
    End If
    Next i
    
    hedef.Select
    MsgBox "İşleminiz tamamlandı."
    
End Sub

 

[RBozkurt]

Teşekkürler @muratboz06 hocam. Elinize sağlık. Fazladan 1 sütun geldi ama problem değil. Çok teşekkürler.

 

[muratboz06]

Rica ederim.
Adresi istemiyorsanız;
hedef.Cells(sonSatirHedef, 9).Value = kaynak.Cells(i + 3, 2).Value 'Adres bir sonraki sütuna taşındı
satırını silebilirsiniz.

 

[RBozkurt]

Merhaba,
@muratboz06 hocam 2 yıl önce desteğinizi almıştım.
Ekteki dosyada bulunan J sütununa işaretlediğim bilgilerin getirilmesi mümkün müdür?
Aynı satırdaki "-" den önceki veri getiriliyordu. "-"den sonraki verinin getirilmesi gerekir.
Teşekkürler.

 

[RBozkurt]

Alttaki satır ile problem çözülmüştür.
hedef.Cells(sonSatirHedef, 10).Value = Right(kaynak.Cells(i - 1, 1), Len(kaynak.Cells(i - 1, 1)) - InStr(1, kaynak.Cells(i - 1, 1), "-", 1))