Soru Toplu Sorgu

[furens]

Arkadaşlar kolay gelsin.
Benim bir sorum olacaktı
Bir excell çalışma kitabında sayfa1 de veriler var. sayfa 2 de A2 hücresinden başlayan A500 kadar olabilen TC kimlik numaraları var.
Bu sayfa2 deki tc kimlik numaralarını toplu olarak A2 ' den başlayarak en son dolu hücreye kadar seçip bu kimlik numaralarını
Sayfa1 deki verilerden aratarak kaydı bulunanların bilgilerini sayfa3 aktarması yapılabilir mi? kaydı yoksa kaydı yoktur yazılabilir mi
Yalnız sayfa1 deki şahısların birden fazla kaydı olabiliyor o bilgilerin tamamını alması gerekiyor.

Evren hocanın yaptığı Ara_Bul vardı. Çok güzel f2 hücresine şahıs tc giriyorsun o şahsın diğer sayfadaki olan bütün kayıtlarını getiriyordu.
bunun toplu sorgulama şeklinde yapılabilme olanağı var mı?

Sub ARABAKALIM()
Dim k As Range, ilk_adres As String, sat As Long, sut As Byte
Sheets("Arama Sayfası").Select
If MsgBox("[ " & Range("F2").Value & " ] İsimli sahısı aramak istiyormusunuz?", vbYesNo + vbQuestion, " ARA BAKALIM HADİ") = vbNo Then Exit Sub
Application.ScreenUpdating = False
Range("A6:AF70000").ClearFormats
Range("A6:AF70000").ClearContents
sat = 6
Set k = Sheets("Veri").Range("A2:A47680").Find(Range("F2").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
ilk_adres = k.Address
Do
Cells(sat, "A").Value = sat - 10
For sut = 0 To 7
Cells(sat, k.Offset(0, sut).Column).Value = k.Offset(0, sut).Value
Next sut
sat = sat + 1
Set k = Sheets("Veri").Range("A2:A47680").FindNext(k)
Loop While k.Address <> ilk_adres And Not k Is Nothing
Set k = Nothing
Application.ScreenUpdating = True
If sat > 11 Then
MsgBox " Arama Tamamlandı..", vbOKOnly + vbInformation, Application.UserName & " BULABİLDİNMİ BARİ?"

End If
End If
End Sub

 

[furens]

Arkadaşlar bu konu ile ilgili bir fikri olan yokmu?

 

[Necdet]

Merhaba,

Fikri olan çoktur da, kimse yazacağı kodlar için veri hazırlamak istemez.
Siz 3-5 satırlık örnek dosya hazırlayıp, paylaşım sitelerinden birine (dosya.tc dosya.co gibi) yüklerseniz yardım almanız daha da kolaylaşır ve hızlanır.

 

[furens]

Merhaba,

Fikri olan çoktur da, kimse yazacağı kodlar için veri hazırlamak istemez.
Siz 3-5 satırlık örnek dosya hazırlayıp, paylaşım sitelerinden birine (dosya.tc dosya.co gibi) yüklerseniz yardım almanız daha da kolaylaşır ve hızlanır.

Toplu_Sorgu.xlsm dosyasını indir - download

Toplu_Sorgu.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

dosyayı yükledim.
2.sayfada bulunan sayısı değişebilir tc leri toplu olarak 1.sayfadan sorgulayıp bulunan bütün kayıtları 3.sayfaya getirecek kaydı olmayanları kaydı yok diye yazması
şimdiden tşk

 

[Necdet]

Deneyiniz.

Private Sub CommandButton1_Click()

Dim i   As Long, _
    j   As Long, _
    c   As Range, _
    adr As String, _
    sh1 As Worksheet, _
    sh2 As Worksheet, _
    sh3 As Worksheet

Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
Set sh3 = Sheets("Sayfa3")

sh3.Range("A1").CurrentRegion.Offset(1).ClearContents

j = 1

For i = 2 To sh2.Cells(Rows.Count, "A").End(3).Row
    
    With sh1.Range("A:A")
        Set c = .Find(sh2.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            adr = c.Address
            Do
                j = j + 1
                sh1.Range("A" & c.Row & ":D" & c.Row).Copy sh3.Cells(j, "A")
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> adr
        Else
            sh2.Cells(i, "B") = "Kayıt Bulunamadı.."
        End If
    End With
Next i
    
MsgBox "İşlem Tamamlanmıştır...."

End Sub

 

[furens]

Allah Razı olsun Çok güzel olmuş. Bilgin artsın.