Kapalı kitaplıklardan veri sorgulama

[Abdulhey]

Bir klasör içerisinde bulunan farklı isimlerdeki kitaplıklarda veri sorgulaması yaptırmak istiyorum. Örnek dosya ekledim.
Örnek klasördeki istatistik kitabında diğer kitapların f:f sütünunda a(x)... satırndaki değeri bulup varsa karşısına 1 yoksa 0 yazsın istiyorum.
Fonksiyonla yapıyorum ancak sayfalar kapalıyken bu işlemi yapamıyorum #değer hatası veriyor.
makro ile klasördeki kitapları açmadan verileri sorgulatmanın bir kolayı varmıdır ?

 

[Abdulhey]

Kimseden bir öneri yokmudur ?

 

[Murat OSMA]

Şu kodları deneyiniz;

Sub Emre()
    Dim evn As Object, dosya As Object
    Dim isim As Range, bul As Range
    Dim sutun As Integer
    Dim yol As String
    On Error Resume Next
    yol = ThisWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set evn = CreateObject("Scripting.FileSystemObject"): sutun = 2
    For Each dosya In evn.getfolder(yol).Files
    If dosya.Name <> ThisWorkbook.Name And _
        dosya.Name <> "~$İstatistik.xlsm" Then
        Cells(1, sutun).Value = dosya.Name
        Set ac = Workbooks.Open(dosya)
        With ThisWorkbook.Sheets(1)
            For Each isim In .Range("A2:A" & .Range("A65536").End(3).Row)
            Set bul = ActiveWorkbook.Sheets(1).Columns(6).Find(isim.Value, , , 1)
                If Not bul Is Nothing Then
                    .Cells(isim.Row, sutun).Value = 1
                        Else
                    .Cells(isim.Row, sutun).Value = 0
                End If
            Next isim
        End With
    End If
    sutun = sutun + 1
    ac.Close = False
    Next dosya
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set bul = Nothing: Set isim = Nothing
    Set dosya = Nothing: Set evn = Nothing
    a = Empty: yol = vbNullString
End Sub

Dosyayı da ekliyorum...

 

[Abdulhey]

Murat bey muhteşemsiniz teşekkürker.
Kabalık etmiş olmaz isem bir soru daha sormak isterim.
İstatistik anasayfa a:a sütünunda olmayıp atıyorum veri çekilen sayfaların f:f sütünlarında bulunan yeni değerleri anasayfa a:a sütünda en son değerden sonra yazdırmak mümkün olabilirmi ?

sorumu dosyaya ekledim.

 

[Murat OSMA]

Estağfurullah Sn. Abdulhey,

O konuya ile yarın ilgilenirim.

 

[Abdulhey]

Murat bey yeni bir dosya ekledim
açıklama içerisinde
ilk istediğimi biraz revize ettim
kitapları tek sayfada birleştirdim.
yeni kitap üzerinde yeni ihtiyaçlar oldu
müsait olduğunuzda ilgilenebilirseniz sevinirim.

selametle

 

[Murat OSMA]

Şimdilik şu kodları bir deneyiniz;

Sub Emre()
    Dim syf As Worksheet
    Dim evn As Range
    Dim son As Integer
    Application.ScreenUpdating = False
    son = Range("A65536").End(3).Row
    For Each syf In ThisWorkbook.Worksheets
        If syf.Name <> "İstatistik" Then
            For Each evn In syf.Range("A1:A" & syf.Range("A65536").End(3).Row)
                For i = 2 To Range("A65536").End(3).Row
                    If evn.Value <> Cells(i, 1) Then
                        Cells(son, 1) = evn.Value
                    End If
                Next i
            Next evn
        End If
        son = son + 1
    Next syf
    ActiveSheet.Range("$A$1:$A$26472").RemoveDuplicates Columns:=1, Header:=xlYes
    Application.ScreenUpdating = True
    Set evn = Nothing: Set syf = Nothing: son = Empty
End Sub

 

[Abdulhey]

Süpersin teşekkürler...

 

[Murat OSMA]

Rica ederim, iyi günler.