Function kod çok yavaş

[polis-53]

Merhba arkadaşlar ekteki kod exceli çok aşırıkasıyor sorun nerede.

Function DÜŞEYARA_AYRAC(Aranan_Deger As Variant, Bakilan_Aralik As Range, Getirilecek_Aralik As Range, ayrac As Variant) As String
Dim sonuc As String
Dim sonuc_Gecici As String
Dim satir As Long
Dim sutun As Long
Const bslAyrac = "|||"
sonuc = bslAyrac
For satir = 1 To Bakilan_Aralik.Rows.Count
For sutun = 1 To Bakilan_Aralik.Columns.Count
If Bakilan_Aralik.Cells(satir, sutun).Value Like "*" & Aranan_Deger & "*" Then
sonuc_Gecici = Getirilecek_Aralik.Offset(satir - 1, sutun - 1).Cells(1, 1).Value
If InStr(1, sonuc, bslAyrac & sonuc_Gecici & bslAyrac) = 0 Then
sonuc = sonuc & sonuc_Gecici & bslAyrac
End If
Next
sonuc = Replace(sonuc, bslAyrac, ayrac)
If Left(sonuc, 1) = ayrac Then sonuc = Mid(sonuc, 2)
If Right(sonuc, 1) = ayrac Then sonuc = Left(sonuc, Len(sonuc) - 1)
If Len(sonuc) > 0 Then DÜŞEYARA_AYRAC = sonuc Else DÜŞEYARA_AYRAC = “BULUNAMADI”
End Function

 

[HücrelereFısıldayanAdam]

makro hücreleri teker teker işliyor sanırım. Makronun sıfırdan ele alınması gerekli.
Verileri dizilere aktarmayı deneyebilirsiniz: veya verileri önce bir sözlüğe aktarmayı deneyebilirsiniz.

Function DÜŞEYARA_AYRAC(Aranan_Deger As Variant, Bakilan_Aralik As Range, Getirilecek_Aralik As Range, ayrac As Variant) As String
    Dim sonuc As String
    Dim sonuc_Gecici As String
    Dim sonuclarListesi As String
    Dim satir As Long, sutun As Long
    Dim aralikDegerleri As Variant, getirilecekDegerler As Variant
    
    aralikDegerleri = Bakilan_Aralik.Value
    getirilecekDegerler = Getirilecek_Aralik.Value
    
    For satir = 1 To UBound(aralikDegerleri, 1)
        For sutun = 1 To UBound(aralikDegerleri, 2)
            If aralikDegerleri(satir, sutun) Like "*" & Aranan_Deger & "*" Then
                sonuc_Gecici = getirilecekDegerler(satir, sutun)
                
                If InStr(1, sonuclarListesi, ayrac & sonuc_Gecici & ayrac) = 0 Then
                    sonuc = sonuc & sonuc_Gecici & ayrac
                    sonuclarListesi = sonuclarListesi & ayrac & sonuc_Gecici & ayrac ' Benzersiz listesine ekle
                End If
            End If
        Next sutun
    Next satir
    
    If Len(sonuc) > 0 Then
        sonuc = Left(sonuc, Len(sonuc) - Len(ayrac))
        DÜŞEYARA_AYRAC = sonuc
    Else
        DÜŞEYARA_AYRAC = "BULUNAMADI"
    End If
End Function

 

[HücrelereFısıldayanAdam]

Denediniz mi?