Dosyanızı ekleyebilirsiniz
Cevaplanmışlara taşındığı için dosya eklenemiyordu
Tekrar Sorular bölümüne taşındı

gönderiyorum hocam, sayfada gerekli açıklamalar var, teşekkürler.

Ado ile yaptım eğer yavaş olursa bakarız.

süper olmuş elinize sağlık, çok çok teşekkür ederim, bayağı uzun listeler vardı bu sayede tek tıkla hallolacak, emeğiniz için çok teşekkürler.

Rica ederim.
Birde düşeyara manığı ile yaptım bu daha hızlı olması gerek.

Not:Kod ve dosya güncellendi.12.05.2022 21:40

Sub Arama()

    Dim kitapVarmi As String

    Dim syf As Worksheet: Set syf = ThisWorkbook.Worksheets("Sayfa1")

    

    With syf

        With .Range("B2:B" & .Cells(Rows.Count, 1).End(3).Row + 1)

            syf.Range("B2:B" & Rows.Count).Clear

            kitapVarmi = ThisWorkbook.path & Application.PathSeparator & syf.[G1] & ".xlsx"

            If Dir(kitapVarmi) = "" Then GoTo sonSub

            .Formula = "=IFERROR(VLOOKUP(" & syf.[A2].Address(0, 0) & ",'" & ThisWorkbook.path & _

                        Application.PathSeparator & "[" & syf.[G1] & ".xlsx]Sayfa1'!A:C,3,0),"""")"

            .Value = .Value

        End With

    End With

sonSub:

    Set syf = Nothing

End Sub



Private Sub CommandButton1_Click()

    Arama

End Sub



Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address(0, 0) = "G1" Then Arama

End Sub

Çok iyi oldu icap ederse bunu da kullanırım, çok teşekkür ederim sayın feraz, işimiz gücümüz "işimiz" ve bu konuda çok yardımcı oluyorsunuz , işimizi kolaylaştırıyorsunuz, Allah emeğinizi karşılıksız bırakmasın , çok teşekkürler.