• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru İkinci Sayfaya Veri Çekme Hakkında

RBozkurt

RBozkurt

????
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
753
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
İ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?

Kod: 
https://dosyam.org/9up/%C3%96rnek_Veri.xlsx
 
Linkteki çalışma işinizi görecektir. Mernis listesiniz hep aynı formatta olmalıdır.
dosyam.org

Bilgi

Bilgi
dosyam.org dosyam.org
 
@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.
 
İ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.

e5d0x4.png
 
Yukarıda sizinle paylaşmış olduğum excel dosyasında modul1 de yer alan kodu aşağıdaki ile değiştiriniz.
Kod: 
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
 
@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?

Kod: 
https://dosyam.org/720/%C3%96rnek_Veri.xlsx
 
Deneyiniz.
Kod: 
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
 
Teşekkürler @muratboz06 hocam. Elinize sağlık. Fazladan 1 sütun geldi ama problem değil. Çok teşekkürler.
 
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.
 
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.
 

Ekli dosyalar

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))
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst