Belli bir metin ile başlayanların benzersizlerini listelemek

[Believing]

Sayın Uzman arkadaşlar,

Ekteki örnek çalışmanın "B40:B2000" aralığında metinden ve sayılardan oluşan veriler bulunmaktadır.
Aynı sütunun "B7:B36" aralığına ise, "B40:B2000" aralığındaki "Total" ile başlayanların benzersizlerini listelemek istiyorum.
Sitede bulunan bir çok örneği incelememe rağmen olumlu bir sonuca ulaşamadım.
Benzersizlerin listesini oluşturabilmem için nasıl bir yol izlemeliyim?
Benim için çok kıymetli olan yardımlarınızı rica ediyorum.

Saygılarımla,

 

[Ziynettin]

Ekli dosyanıza ait yapılan çalışma.

Sub test()

Sheets("DATABASE").Select

a = [B40:B200].Value

Set dz = CreateObject("scripting.dictionary")

For i = 1 To UBound(a)
    krt = Left(a(i, 1), 5)
    If krt = "Total" Then
    dz(a(i, 1)) = ""
    End If
Next i

[B7:B36].ClearContents

If dz.Count > 30 Then
    MsgBox "Veriniz yazdırma alanından fazla.", vbCritical
    Exit Sub
End If

If dz.Count > 0 Then
    [B7].Resize(dz.Count) = Application.Transpose(dz.keys)
    Set alan = [B7].Resize(dz.Count)
    alan.Sort [B7], 1
End If

MsgBox "İşlem bitti...", vbInformation

End Sub

 

[Believing]

Sayın Ziynettin bey,

Ellerinize ve emeğinize sağlık. Bu konu için oldukça fazla zaman harcamıştım.
ALLAH sizden ve sevdiklerinizden razı olsun.
Hakkınızı helal ediniz lütfen.

Saygılarımla,

 

[Ziynettin]

Amin.

ALLAH hepimizden razı olsun.

Hakkımız varsa da helal olsun.

Bizden de saygılar.

 

[Korhan Ayhan]

Alternatif;

ADO ile çözüm uygulanmıştır.

Option Explicit

Sub Benzersiz_Liste()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Range("B7:B36").ClearContents
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sorgu = "Select Distinct F1 From [DATABASE$B40:B2000] Where F1 Like 'Total%' Order By F1 Asc"
    
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then
        Range("B7").CopyFromRecordset Kayit_Seti
    End If
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[Believing]

Sayın Korhan bey,

Ne kadar takdir etsem azdır. Yiğidi öldür hakkını yeme demişler. Çözümleriniz oldukça etkileyici...
ALLAH sizden ve sevdiklerinizden razı olsun.
Hakkınızı helal ediniz lütfen.

Saygılarımla,

 

[Korhan Ayhan]

Hakkım varsa helal olsun..