Sayfalarda bulunan verilerden T.C. Kimlik no olan satırları listeleme

[nongeyikm]

Merhabalar,

Ekli sayfa sgk sitesinden alınmıştır. Dosya içerisindeki sayfa sayısı yaklaşık 100 sayfa olabilecektir.
Yapmak istediğim; bu sayfalardaki B5:AZ50000 aralığında ve (SGK meslek sayfası hariç) sadece T.C. kimlik no satırlarını örnekte olduğu gibi alt alta Listele sayfasında (değer olarak kopyalanacak) listelemek.

Not : fikir vermek adına, B sütununda 11 haneli ve numerik olan değerlerin satırları

Saygılar,

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[nongeyikm]

Sn. M.Uygun

Harika oldu. elinize beyninize sağlık.

Bir de aşağıdaki koda bir ekleme yapmam gerek. En sona ücret olarak bir sütun daha ekledim. modüle bu sütunu da ekleyebilir misiniz.



Sub YeniListe()
Dim Sh As Worksheet
Dim Dic1 As Object, Dic2 As Object, YeniListe As Object, Yeni
Dim i As Integer, Son As Integer, k As Integer, x As Integer, Minimum As Date

Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
Set YeniListe = CreateObject("Scripting.Dictionary")
Set Sh = Worksheets("Bunakopyala")
Son = Sh.Range("C" & Rows.Count).End(3).Row
If Son < 3 Then MsgBox "Veriler Eksik": Exit Sub
Worksheets("YeniListe").Range("C3:H" & Rows.Count).ClearContents
Dizi = Sh.Range("A3").Resize(Son - 2, 8).Value
For i = 1 To UBound(Dizi)
If Dizi(i, 7) <> "" Then
If Not Dic1.Exists(Dizi(i, 3)) Then
Dic1.Add Dizi(i, 3), i
Else
Dic1(Dizi(i, 3)) = Dic1(Dizi(i, 3)) & "--" & i
End If
End If
If Dizi(i, 8) <> "" Then
If Not Dic2.Exists(Dizi(i, 3)) Then
Dic2.Add Dizi(i, 3), i
Else
Dic2(Dizi(i, 3)) = Dic2(Dizi(i, 3)) & "--" & i
End If
End If
Next i
ReDim Liste(1 To Rows.Count, 1 To 8)
For i = 0 To Dic1.Count - 1
For k = 0 To UBound(Split(Dic1.items()(i), "--"))
Say = Say + 1
Liste(Say, 1) = Dizi(Split(Dic1.items()(i), "--")(0), 1)
Liste(Say, 2) = Dizi(Split(Dic1.items()(i), "--")(0), 2)
Liste(Say, 3) = Dizi(Split(Dic1.items()(i), "--")(0), 3)
Liste(Say, 4) = Dizi(Split(Dic1.items()(i), "--")(0), 4)
Liste(Say, 5) = Dizi(Split(Dic1.items()(i), "--")(0), 5)
Liste(Say, 6) = Dizi(Split(Dic1.items()(i), "--")(0), 6)
Liste(Say, 7) = Dizi(Split(Dic1.items()(i), "--")(k), 7)
YeniListe.RemoveAll
If Dic2.Exists(Dic1.Keys()(i)) Then
Yeni = Split(Dic2(Dic1.Keys()(i)), "--")
Minimum = 0
For x = 0 To UBound(Yeni)
YeniListe.Add Yeni(x), 1
If Liste(Say, 7) <= Dizi(Yeni(x), 8) Then
If Minimum = 0 Then
Minimum = Dizi(Yeni(x), 8)
Else
Minimum = WorksheetFunction.Min(Minimum, Dizi(Yeni(x), 8))
End If
End If
Next x
If Minimum > 0 Then
For x = 1 To YeniListe.Count
If Minimum = YeniListe.Keys()(x - 1) Then YeniListe.Remove Minimum: Exit For
Next x
Liste(Say, 8) = Minimum
Dic2(Dic1.Keys()(i)) = Join(YeniListe.Keys, "--")
End If
End If
Next k
Next i
Worksheets("YeniListe").Range("A3").Resize(Say, 8) = Liste
End Sub