klasördeki dosyaların "B" Sutununda "x" yazısını bul bir altını al

[miadanoz]

Merhaba,

Bir klasörde 5.000 den fazla excel dosyam bulunuyor.

Benim yapmak istediğim bir excel'de dosya isimlerini listeletip hemen karşısına B sütununda bulunan ama hangi satırda olduğu belirsiz bir hücredeki yazıyı yazdırmak.

Bu yazıyı bulabilmesi için tek ortak nokta ise şu;

B sütununda bulunan "Tarifi" yazısının bir altındaki yazı olması.

Veriler İçin Örnek dosyalar : https://dosya.co/ohmacukjfd5w/ornek.zip.html

Böyle bir şey mümkün müdür acaba ? Yardımcı olabilirseniz çok sevinirim.

ornek çıktı : https://dosya.co/knzjdetv1omk/ornek.xlsx.html

 

[bmutlu966]

Deneyiniz.

İndir Dosya İşlemleri

Dosyayı indir Dosya İşlemleri

dosya.co

 

[miadanoz]

elinize sağlık hocam. çok teşekkür ederim.

 

[dEdE]

Alternatif,
5.000 den fazla dosya varsa hız önemli. Aşağıdaki kodları bir modüle yapıştırarak dener misiniz?

Sub Listele_Yaz()
ZMN = Timer
Application.ScreenUpdating = False
Yol = "C:\Users\ozdem\Desktop\xx\" 'Dosya yolunu kendinize göre düzenlemelisiniz.
    Set SCO = CreateObject("scripting.filesystemobject")
    Columns("A:B").Clear
    I = 2
For Each Dosya In SCO.GetFolder(Yol).Files
    Cells(I, 1) = Dosya.Name
    I = I + 1
Next
    Columns("A:A").AutoFit
    Columns("A:A").VerticalAlignment = xlCenter
For j = 2 To 5'Dosya sayısına göre değiştiriniz
    Set K1 = Workbooks.Open(Yol & ThisWorkbook.Sheets("Sayfa1").Cells(j, 1))
   
    With ActiveWorkbook.Sheets("1").Range("B:G")
        Set c = .Find("Tarifi", LookIn:=xlValues)
        If Not c Is Nothing Then
            ThisWorkbook.Sheets("Sayfa1").Cells(j, 2) = Cells(c.Row + 1, 2)
        End If
    End With
   
    K1.Close False
Next j
    Columns("B:B").AutoFit
    Application.ScreenUpdating = True
    MsgBox "İşlem " & Format(Timer - ZMN, "0.00") & " Saniyede Tamamlandı", vbInformation
End Sub

NOT: ADO ile dosyaları açmadan daha hızlı çalışan bir kod oluşturulabilir. Üstadlar bir el atarsa ben de öğrenmiş olurum.

 

[miadanoz]

çok teşekkür ederim hepinize. gerçekten üstadsınız. çok çok sağolun.

 

[Korhan Ayhan]

ADO ile alternatif...

Bütün dosyalar ile makronun çalışacağı dosya (Rapor.xlsm) aynı klasörde olmalıdır.

Spoyler: Ado_Uygulaması

Option Explicit

Sub Getting_Data_From_Excel_Files_In_Folder()
    Dim My_Connection As Object, My_Recordset As Object
    Dim My_Folder As String, My_File As String
    Dim Searched_Data_Row As Long
    Dim Last_Row As Long, Process_Time As Double
  
    Process_Time = Timer
  
    Application.ScreenUpdating = False
  
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    Set My_Recordset = VBA.CreateObject("AdoDb.Recordset")

    My_Folder = ThisWorkbook.Path & "\"

    Range("A:B").ClearContents
    Last_Row = 1

    My_File = Dir(My_Folder & "*.xls*")

    While My_File <> ""
        If My_File <> "Rapor.xlsm" Then
            My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            My_Folder & My_File & ";Extended Properties=""Excel 12.0;Hdr=No"""
              
            My_Recordset.Open "Select F1 From [1$B:B]", My_Connection, 1, 1
            My_Recordset.Find "F1 ='Tarifi'"
          
            Searched_Data_Row = My_Recordset.AbsolutePosition + 1
         
            If My_Recordset.State <> 0 Then My_Recordset.Close
         
            My_Recordset.Open "Select First(F1) From [1$B" & Searched_Data_Row & ":B] Where F1 Is Not Null", My_Connection, 1, 1
         
            Cells(Last_Row, 1) = My_File
            Cells(Last_Row, 2).CopyFromRecordset My_Recordset
            Last_Row = Last_Row + 1
      
            If My_Recordset.State <> 0 Then My_Recordset.Close
            If My_Connection.State <> 0 Then My_Connection.Close
        End If
      
        My_File = Dir
    Wend

    Set My_Connection = Nothing
    Set My_Recordset = Nothing

    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[dEdE]

Merhaba,
4 numaralı mesajımdaki kodları *.xlsx uzantılı 10 dosya için denedim. 4.11 saniyede tamamlandı. Sayın Korhan Ayhan'ın kodları ise 1.17 saniyede tamamladı. ADO hız farkını net bir biçimde görüyoruz.
Bir noktada takıldım.
Sayın Korhan Ayhan'ın kodunu kopyalayıp yapıştırarak *.xlsx uzantılı dosyalarda deneyince kodun

My_File = Dir(My_Folder & "*.xls*")

satırındaki "*.xls*" şeklindeki ifade bende çalışmadı. Bu ifadeyi "*.xlsx" şeklinde değiştirince çalıştı ve yukarıdaki sonucu aldım.
Koddaki sonuncu * simgesi bende işlevsiz gibi duruyor, böyle olmamalı diye düşünüyorum. Bu durumun bir açıklaması olabilir mi?