A sütunu "" içeriyorsa c sütununa karşılık gelen verisini listeleme

R

reallerking

Katılım
7 Ocak 2017
Mesajlar
34
Excel Vers. ve Dili
2010
Merhaba,

Geçmiş yıllara ait kasa defteri olarak kullandığım yıl yıl ve ay ay ayrılmış halde klasörlerim mevcut. Ör: 2018 klasörünün içinde ŞUBAT isimli klasör. Bu klasörlerde tarihine göre isimlendirilmiş dosyalar mevcut. Ör: 01.02.2018.

Yapmak istediğim şu; ilgili ayın içinde veya tüm yıl ve ayları kapsayacak şekilde (tüm dosyalarda ilgili sütunlar ilgili verileri içeriyor/veriler değişse de şablon aynı) bir arama yapmak, ilgili kelimeyi içeren satırın karşısına denk gelen sayıları listelemek. Bu şekilde; örneğin "banka" verisini içeren satıra karşılık gelen tutarları öğrenebilirsem ilgili tarihten bu yana "banka" üzerinden ne kadar tahsilat gerçekleştirmişim onu öğreneceğim.

Ör: A6:A31 arasında "banka" verisini içeren satırları bularak C6:C31 arasına denk gelen karşılıklarını listelemek.

Umarım anlatabilmişimdir sanırım makro yardımı gerekecek, yardımlarınızı bekliyorum...
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
618
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
reallerking' Alıntı:
Merhaba,

Geçmiş yıllara ait kasa defteri olarak kullandığım yıl yıl ve ay ay ayrılmış halde klasörlerim mevcut. Ör: 2018 klasörünün içinde ŞUBAT isimli klasör. Bu klasörlerde tarihine göre isimlendirilmiş dosyalar mevcut. Ör: 01.02.2018.

Yapmak istediğim şu; ilgili ayın içinde veya tüm yıl ve ayları kapsayacak şekilde (tüm dosyalarda ilgili sütunlar ilgili verileri içeriyor/veriler değişse de şablon aynı) bir arama yapmak, ilgili kelimeyi içeren satırın karşısına denk gelen sayıları listelemek. Bu şekilde; örneğin "banka" verisini içeren satıra karşılık gelen tutarları öğrenebilirsem ilgili tarihten bu yana "banka" üzerinden ne kadar tahsilat gerçekleştirmişim onu öğreneceğim.

Ör: A6:A31 arasında "banka" verisini içeren satırları bularak C6:C31 arasına denk gelen karşılıklarını listelemek.

Umarım anlatabilmişimdir sanırım makro yardımı gerekecek, yardımlarınızı bekliyorum...
Genişletmek için tıkla ...
Deneyiniz. 2018 klasorunun icine yeni bi excel acip kodu çalıştıriniz.
Kod: 
Sub ADO_Ile_KapaliDosyaTara()

    Dim dosyaYolu As String
    Dim klasorYolu As String
    Dim hedefDosya As String
    Dim conn As Object, rs As Object
    Dim sorgu As String
    Dim sonucSayfasi As Worksheet
    Dim satir As Long

    ' Bu çalışma kitabının bulunduğu klasör
    klasorYolu = ThisWorkbook.Path & "\"

    ' Örnek dosya adı (gerçek durumda döngü ile her dosyada bu işlem yapılabilir)
    hedefDosya = "01.02.2018.xlsx" ' klasörün içindeki bir dosya
    dosyaYolu = klasorYolu & hedefDosya

    ' Sonuçları yazmak için yeni sayfa
    Set sonucSayfasi = ThisWorkbook.Sheets.Add
    sonucSayfasi.Name = "ADO_Sonuç"
    sonucSayfasi.Range("A1:C1").Value = Array("Satır No", "Anahtar Kelime", "Tutar")
    satir = 2

    ' ADO bağlantısı
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    ' Bağlantı dizesi - sadece .xlsx için uygundur
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & dosyaYolu & ";" & _
              "Extended Properties='Excel 12.0 Xml;HDR=No;IMEX=1';"

    ' A6:C31 aralığını okuyacak SQL sorgusu - Sayfa1 varsayılmış
    sorgu = "SELECT F1, F3 FROM [Sayfa1$A6:C31] WHERE F1 LIKE '%banka%'"

    rs.Open sorgu, conn, 1, 1

    ' Sonuçları yaz
    Do Until rs.EOF
        sonucSayfasi.Cells(satir, 1).Value = satir - 1
        sonucSayfasi.Cells(satir, 2).Value = rs.Fields(0).Value
        sonucSayfasi.Cells(satir, 3).Value = rs.Fields(1).Value
        satir = satir + 1
        rs.MoveNext
    Loop

    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing

    MsgBox "İşlem tamamlandı. " & satir - 2 & " kayıt bulundu.", vbInformation

End Sub
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
335
Excel Vers. ve Dili
Excel 2021 Türkçe
Merhaba, mevcut tüm dosyalarınızı yedek aldıktan sonra şunu deneyip sonucu paylaşabilir misiniz;

Kod: 
Sub KelimeAramaVeToplama()
    Dim anaKlasor As String
    Dim yilKlasor As String
    Dim ayKlasor As String
    Dim dosya As String
    Dim arananKelime As String
    Dim bulunanDosyalar As Integer
    Dim bulunanSatirlar As Integer
    Dim toplamTutar As Double
    Dim sonSatir As Integer
    Dim i As Integer
    Dim sonucSayfasi As Worksheet
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim secimYil As Boolean
    Dim secimAy As Boolean
    Dim fso As Object
    Dim klasor As Object
    Dim altKlasor As Object
    Dim dosyaNesne As Object
    Dim satirSayaci As Integer
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Ana Klasörü Seçin (Yıl klasörleri bulunan klasör)"
        .AllowMultiSelect = False
        If .Show = -1 Then
            anaKlasor = .SelectedItems(1)
        Else
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
    End With
    
    arananKelime = InputBox("Aranacak kelimeyi girin:", "Kelime Ara", "banka")
    If arananKelime = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
    
    secimYil = MsgBox("Belirli bir yıl için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
    
    If secimYil Then
        yilKlasor = InputBox("Hangi yıl için arama yapmak istiyorsunuz? (ör: 2018)", "Yıl Seçimi")
        If yilKlasor = "" Then
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
        
        If Not fso.FolderExists(anaKlasor & "\" & yilKlasor) Then
            MsgBox "Belirtilen yıl klasörü bulunamadı: " & yilKlasor, vbExclamation
            Exit Sub
        End If
        
        secimAy = MsgBox("Belirli bir ay için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
        
        If secimAy Then
            ayKlasor = InputBox("Hangi ay için arama yapmak istiyorsunuz? (ör: OCAK)", "Ay Seçimi")
            If ayKlasor = "" Then
                MsgBox "İşlem iptal edildi.", vbInformation
                Exit Sub
            End If
            
            If Not fso.FolderExists(anaKlasor & "\" & yilKlasor & "\" & ayKlasor) Then
                MsgBox "Belirtilen ay klasörü bulunamadı: " & ayKlasor, vbExclamation
                Exit Sub
            End If
        End If
    End If
    
    Set sonucSayfasi = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    sonucSayfasi.Name = "Arama_Sonuclari_" & Format(Now(), "yyyymmdd_hhmmss")
    sonucSayfasi.Cells(1, 1).Value = "Dosya Adı"
    sonucSayfasi.Cells(1, 2).Value = "Satır"
    sonucSayfasi.Cells(1, 3).Value = "İçerik"
    sonucSayfasi.Cells(1, 4).Value = "Tutar"
    bulunanDosyalar = 0
    bulunanSatirlar = 0
    toplamTutar = 0
    satirSayaci = 2
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "Dosyalar aranıyor..."
    Set klasor = fso.GetFolder(anaKlasor)
    
    If secimYil Then
        If secimAy Then
            AraVeListele anaKlasor & "\" & yilKlasor & "\" & ayKlasor, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
        Else
            Set klasor = fso.GetFolder(anaKlasor & "\" & yilKlasor)
            For Each altKlasor In klasor.SubFolders
                AraVeListele altKlasor.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
            Next altKlasor
        End If
    Else
        For Each altKlasor In klasor.SubFolders
            If fso.FolderExists(altKlasor.Path) Then
                Set klasor2 = fso.GetFolder(altKlasor.Path)
                For Each altKlasor2 In klasor2.SubFolders
                    AraVeListele altKlasor2.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
                Next altKlasor2
            End If
        Next altKlasor
    End If
    
    sonucSayfasi.Cells(satirSayaci, 3).Value = "TOPLAM:"
    sonucSayfasi.Cells(satirSayaci, 4).Value = toplamTutar
    sonucSayfasi.Cells(satirSayaci, 4).NumberFormat = "#,##0.00 ₺"
    sonucSayfasi.Cells(satirSayaci, 3).Font.Bold = True
    sonucSayfasi.Cells(satirSayaci, 4).Font.Bold = True
    sonucSayfasi.Columns("A:D").AutoFit
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    MsgBox "Arama tamamlandı!" & vbCrLf & _
           "İncelenen Dosya Sayısı: " & bulunanDosyalar & vbCrLf & _
           "Bulunan Satır Sayısı: " & bulunanSatirlar & vbCrLf & _
           "Toplam Tutar: " & Format(toplamTutar, "#,##0.00 ₺"), vbInformation, "Arama Sonuçları"
End Sub

Sub AraVeListele(klasorYolu As String, arananKelime As String, sonucSayfasi As Worksheet, ByRef bulunanDosyalar As Integer, ByRef bulunanSatirlar As Integer, ByRef toplamTutar As Double, ByRef satirSayaci As Integer)
    Dim fso As Object
    Dim klasor As Object
    Dim dosya As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim sonSatir As Integer
    Dim dosyaYolu As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set klasor = fso.GetFolder(klasorYolu)
    
    For Each dosya In klasor.Files
        If LCase(Right(dosya.Name, 4)) = ".xls" Or LCase(Right(dosya.Name, 5)) = ".xlsx" Or LCase(Right(dosya.Name, 5)) = ".xlsm" Then
            dosyaYolu = dosya.Path
            Application.StatusBar = "İnceleniyor: " & dosya.Name
            
            On Error Resume Next
            Set wb = Workbooks.Open(dosyaYolu, ReadOnly:=True, UpdateLinks:=False)
            On Error GoTo 0
            
            If Not wb Is Nothing Then
                bulunanDosyalar = bulunanDosyalar + 1
                Set ws = wb.Sheets(1)
                sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                For i = 6 To 31
                    If i > sonSatir Then Exit For
                    
                    If InStr(1, LCase(ws.Cells(i, 1).Value), LCase(arananKelime), vbTextCompare) > 0 Then
                        Dim tutar As Double
                        tutar = 0
                        
                        If IsNumeric(ws.Cells(i, 3).Value) Then
                            tutar = CDbl(ws.Cells(i, 3).Value)
                            sonucSayfasi.Cells(satirSayaci, 1).Value = dosya.Name
                            sonucSayfasi.Cells(satirSayaci, 2).Value = i
                            sonucSayfasi.Cells(satirSayaci, 3).Value = ws.Cells(i, 1).Value
                            sonucSayfasi.Cells(satirSayaci, 4).Value = tutar
                            sonucSayfasi.Cells(satirSayaci, 4).NumberFormat = "#,##0.00 ₺"
                            bulunanSatirlar = bulunanSatirlar + 1
                            toplamTutar = toplamTutar + tutar
                            satirSayaci = satirSayaci + 1
                        End If
                    End If
                Next i
                wb.Close SaveChanges:=False
            End If
        End If
    Next dosya
End Sub
 
R

reallerking

Katılım
7 Ocak 2017
Mesajlar
34
Excel Vers. ve Dili
2010
pitchoute' Alıntı:
Merhaba, mevcut tüm dosyalarınızı yedek aldıktan sonra şunu deneyip sonucu paylaşabilir misiniz;

Kod: 
Sub KelimeAramaVeToplama()
    Dim anaKlasor As String
    Dim yilKlasor As String
    Dim ayKlasor As String
    Dim dosya As String
    Dim arananKelime As String
    Dim bulunanDosyalar As Integer
    Dim bulunanSatirlar As Integer
    Dim toplamTutar As Double
    Dim sonSatir As Integer
    Dim i As Integer
    Dim sonucSayfasi As Worksheet
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim secimYil As Boolean
    Dim secimAy As Boolean
    Dim fso As Object
    Dim klasor As Object
    Dim altKlasor As Object
    Dim dosyaNesne As Object
    Dim satirSayaci As Integer
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Ana Klasörü Seçin (Yıl klasörleri bulunan klasör)"
        .AllowMultiSelect = False
        If .Show = -1 Then
            anaKlasor = .SelectedItems(1)
        Else
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
    End With
   
    arananKelime = InputBox("Aranacak kelimeyi girin:", "Kelime Ara", "banka")
    If arananKelime = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
   
    secimYil = MsgBox("Belirli bir yıl için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
   
    If secimYil Then
        yilKlasor = InputBox("Hangi yıl için arama yapmak istiyorsunuz? (ör: 2018)", "Yıl Seçimi")
        If yilKlasor = "" Then
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
       
        If Not fso.FolderExists(anaKlasor & "\" & yilKlasor) Then
            MsgBox "Belirtilen yıl klasörü bulunamadı: " & yilKlasor, vbExclamation
            Exit Sub
        End If
       
        secimAy = MsgBox("Belirli bir ay için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
       
        If secimAy Then
            ayKlasor = InputBox("Hangi ay için arama yapmak istiyorsunuz? (ör: OCAK)", "Ay Seçimi")
            If ayKlasor = "" Then
                MsgBox "İşlem iptal edildi.", vbInformation
                Exit Sub
            End If
           
            If Not fso.FolderExists(anaKlasor & "\" & yilKlasor & "\" & ayKlasor) Then
                MsgBox "Belirtilen ay klasörü bulunamadı: " & ayKlasor, vbExclamation
                Exit Sub
            End If
        End If
    End If
   
    Set sonucSayfasi = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    sonucSayfasi.Name = "Arama_Sonuclari_" & Format(Now(), "yyyymmdd_hhmmss")
    sonucSayfasi.Cells(1, 1).Value = "Dosya Adı"
    sonucSayfasi.Cells(1, 2).Value = "Satır"
    sonucSayfasi.Cells(1, 3).Value = "İçerik"
    sonucSayfasi.Cells(1, 4).Value = "Tutar"
    bulunanDosyalar = 0
    bulunanSatirlar = 0
    toplamTutar = 0
    satirSayaci = 2
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "Dosyalar aranıyor..."
    Set klasor = fso.GetFolder(anaKlasor)
   
    If secimYil Then
        If secimAy Then
            AraVeListele anaKlasor & "\" & yilKlasor & "\" & ayKlasor, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
        Else
            Set klasor = fso.GetFolder(anaKlasor & "\" & yilKlasor)
            For Each altKlasor In klasor.SubFolders
                AraVeListele altKlasor.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
            Next altKlasor
        End If
    Else
        For Each altKlasor In klasor.SubFolders
            If fso.FolderExists(altKlasor.Path) Then
                Set klasor2 = fso.GetFolder(altKlasor.Path)
                For Each altKlasor2 In klasor2.SubFolders
                    AraVeListele altKlasor2.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
                Next altKlasor2
            End If
        Next altKlasor
    End If
   
    sonucSayfasi.Cells(satirSayaci, 3).Value = "TOPLAM:"
    sonucSayfasi.Cells(satirSayaci, 4).Value = toplamTutar
    sonucSayfasi.Cells(satirSayaci, 4).NumberFormat = "#,##0.00 ₺"
    sonucSayfasi.Cells(satirSayaci, 3).Font.Bold = True
    sonucSayfasi.Cells(satirSayaci, 4).Font.Bold = True
    sonucSayfasi.Columns("A:D").AutoFit
   
    Application.StatusBar = False
    Application.ScreenUpdating = True
   
    MsgBox "Arama tamamlandı!" & vbCrLf & _
           "İncelenen Dosya Sayısı: " & bulunanDosyalar & vbCrLf & _
           "Bulunan Satır Sayısı: " & bulunanSatirlar & vbCrLf & _
           "Toplam Tutar: " & Format(toplamTutar, "#,##0.00 ₺"), vbInformation, "Arama Sonuçları"
End Sub

Sub AraVeListele(klasorYolu As String, arananKelime As String, sonucSayfasi As Worksheet, ByRef bulunanDosyalar As Integer, ByRef bulunanSatirlar As Integer, ByRef toplamTutar As Double, ByRef satirSayaci As Integer)
    Dim fso As Object
    Dim klasor As Object
    Dim dosya As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim sonSatir As Integer
    Dim dosyaYolu As String
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set klasor = fso.GetFolder(klasorYolu)
   
    For Each dosya In klasor.Files
        If LCase(Right(dosya.Name, 4)) = ".xls" Or LCase(Right(dosya.Name, 5)) = ".xlsx" Or LCase(Right(dosya.Name, 5)) = ".xlsm" Then
            dosyaYolu = dosya.Path
            Application.StatusBar = "İnceleniyor: " & dosya.Name
           
            On Error Resume Next
            Set wb = Workbooks.Open(dosyaYolu, ReadOnly:=True, UpdateLinks:=False)
            On Error GoTo 0
           
            If Not wb Is Nothing Then
                bulunanDosyalar = bulunanDosyalar + 1
                Set ws = wb.Sheets(1)
                sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                For i = 6 To 31
                    If i > sonSatir Then Exit For
                   
                    If InStr(1, LCase(ws.Cells(i, 1).Value), LCase(arananKelime), vbTextCompare) > 0 Then
                        Dim tutar As Double
                        tutar = 0
                       
                        If IsNumeric(ws.Cells(i, 3).Value) Then
                            tutar = CDbl(ws.Cells(i, 3).Value)
                            sonucSayfasi.Cells(satirSayaci, 1).Value = dosya.Name
                            sonucSayfasi.Cells(satirSayaci, 2).Value = i
                            sonucSayfasi.Cells(satirSayaci, 3).Value = ws.Cells(i, 1).Value
                            sonucSayfasi.Cells(satirSayaci, 4).Value = tutar
                            sonucSayfasi.Cells(satirSayaci, 4).NumberFormat = "#,##0.00 ₺"
                            bulunanSatirlar = bulunanSatirlar + 1
                            toplamTutar = toplamTutar + tutar
                            satirSayaci = satirSayaci + 1
                        End If
                    End If
                Next i
                wb.Close SaveChanges:=False
            End If
        End If
    Next dosya
End Sub
Genişletmek için tıkla ...

Dostum bu çalışma için çok teşekkürler hatasız verileri çekmeyi başardım. Kodlarda oynama yapmama gerek bile kalmadı hatta. İnisiyatifin için tekrar teşekkürler.

Bence oldukça verimli bir çalışma oldu yararlanacak arkadaşlar da vardır.

Belki ufak bir ekleme yapmak gerekirse dosya adlarını gün/ay/yıl olarak küçükten büyüğe sıralattırmak olabilir. Dosya adlarını ".xlsx" uzantılı olarak çektiği için sıralama yaptıramadım. Ayrıca kodlar hangi satır numarası olduğunu da gösteriyor buna benim ihtiyacım yok belki silebiliriz ?

Şimdi bu kısmı hallettik fakat farklı sütunlara da uygulamak istediğimizde hangi kod kısmını güncellemek gerekecek ?

Ör: Yine F6:F31 arasında "banka" verisini içeren satırların G sütununda metin içeriğini aynen alması ve H sütununda tutar kısmını nasıl listeleyebilirim ?

Eğer hangi kod kısmını güncelleyeceğimi bilirsem ilerde oynama yaparak farklı şekillerde kullanabilirim bu makroyu.

Zahmet veriyorum sana belki ama şimdiden yardımın için teşekkürler...
 
R

reallerking

Katılım
7 Ocak 2017
Mesajlar
34
Excel Vers. ve Dili
2010
volki_112' Alıntı:
Deneyiniz. 2018 klasorunun icine yeni bi excel acip kodu çalıştıriniz.
Kod: 
Sub ADO_Ile_KapaliDosyaTara()

    Dim dosyaYolu As String
    Dim klasorYolu As String
    Dim hedefDosya As String
    Dim conn As Object, rs As Object
    Dim sorgu As String
    Dim sonucSayfasi As Worksheet
    Dim satir As Long

    ' Bu çalışma kitabının bulunduğu klasör
    klasorYolu = ThisWorkbook.Path & "\"

    ' Örnek dosya adı (gerçek durumda döngü ile her dosyada bu işlem yapılabilir)
    hedefDosya = "01.02.2018.xlsx" ' klasörün içindeki bir dosya
    dosyaYolu = klasorYolu & hedefDosya

    ' Sonuçları yazmak için yeni sayfa
    Set sonucSayfasi = ThisWorkbook.Sheets.Add
    sonucSayfasi.Name = "ADO_Sonuç"
    sonucSayfasi.Range("A1:C1").Value = Array("Satır No", "Anahtar Kelime", "Tutar")
    satir = 2

    ' ADO bağlantısı
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    ' Bağlantı dizesi - sadece .xlsx için uygundur
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & dosyaYolu & ";" & _
              "Extended Properties='Excel 12.0 Xml;HDR=No;IMEX=1';"

    ' A6:C31 aralığını okuyacak SQL sorgusu - Sayfa1 varsayılmış
    sorgu = "SELECT F1, F3 FROM [Sayfa1$A6:C31] WHERE F1 LIKE '%banka%'"

    rs.Open sorgu, conn, 1, 1

    ' Sonuçları yaz
    Do Until rs.EOF
        sonucSayfasi.Cells(satir, 1).Value = satir - 1
        sonucSayfasi.Cells(satir, 2).Value = rs.Fields(0).Value
        sonucSayfasi.Cells(satir, 3).Value = rs.Fields(1).Value
        satir = satir + 1
        rs.MoveNext
    Loop

    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing

    MsgBox "İşlem tamamlandı. " & satir - 2 & " kayıt bulundu.", vbInformation

End Sub
Genişletmek için tıkla ...
Size de teşekkürler ilginiz için fakat bu kodları uygularken hata aldım. Belki bir yerde ben yanlış yaptım. @pitchoute adlı arkadaşımızın gönderdiği kodlar işimi fazlasıyla gördü.
 
R

reallerking

Katılım
7 Ocak 2017
Mesajlar
34
Excel Vers. ve Dili
2010
pitchoute' Alıntı:
Merhaba, mevcut tüm dosyalarınızı yedek aldıktan sonra şunu deneyip sonucu paylaşabilir misiniz;

Kod: 
Sub KelimeAramaVeToplama()
    Dim anaKlasor As String
    Dim yilKlasor As String
    Dim ayKlasor As String
    Dim dosya As String
    Dim arananKelime As String
    Dim bulunanDosyalar As Integer
    Dim bulunanSatirlar As Integer
    Dim toplamTutar As Double
    Dim sonSatir As Integer
    Dim i As Integer
    Dim sonucSayfasi As Worksheet
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim secimYil As Boolean
    Dim secimAy As Boolean
    Dim fso As Object
    Dim klasor As Object
    Dim altKlasor As Object
    Dim dosyaNesne As Object
    Dim satirSayaci As Integer
  
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Ana Klasörü Seçin (Yıl klasörleri bulunan klasör)"
        .AllowMultiSelect = False
        If .Show = -1 Then
            anaKlasor = .SelectedItems(1)
        Else
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
    End With
  
    arananKelime = InputBox("Aranacak kelimeyi girin:", "Kelime Ara", "banka")
    If arananKelime = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
  
    secimYil = MsgBox("Belirli bir yıl için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
  
    If secimYil Then
        yilKlasor = InputBox("Hangi yıl için arama yapmak istiyorsunuz? (ör: 2018)", "Yıl Seçimi")
        If yilKlasor = "" Then
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
      
        If Not fso.FolderExists(anaKlasor & "\" & yilKlasor) Then
            MsgBox "Belirtilen yıl klasörü bulunamadı: " & yilKlasor, vbExclamation
            Exit Sub
        End If
      
        secimAy = MsgBox("Belirli bir ay için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
      
        If secimAy Then
            ayKlasor = InputBox("Hangi ay için arama yapmak istiyorsunuz? (ör: OCAK)", "Ay Seçimi")
            If ayKlasor = "" Then
                MsgBox "İşlem iptal edildi.", vbInformation
                Exit Sub
            End If
          
            If Not fso.FolderExists(anaKlasor & "\" & yilKlasor & "\" & ayKlasor) Then
                MsgBox "Belirtilen ay klasörü bulunamadı: " & ayKlasor, vbExclamation
                Exit Sub
            End If
        End If
    End If
  
    Set sonucSayfasi = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    sonucSayfasi.Name = "Arama_Sonuclari_" & Format(Now(), "yyyymmdd_hhmmss")
    sonucSayfasi.Cells(1, 1).Value = "Dosya Adı"
    sonucSayfasi.Cells(1, 2).Value = "Satır"
    sonucSayfasi.Cells(1, 3).Value = "İçerik"
    sonucSayfasi.Cells(1, 4).Value = "Tutar"
    bulunanDosyalar = 0
    bulunanSatirlar = 0
    toplamTutar = 0
    satirSayaci = 2
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "Dosyalar aranıyor..."
    Set klasor = fso.GetFolder(anaKlasor)
  
    If secimYil Then
        If secimAy Then
            AraVeListele anaKlasor & "\" & yilKlasor & "\" & ayKlasor, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
        Else
            Set klasor = fso.GetFolder(anaKlasor & "\" & yilKlasor)
            For Each altKlasor In klasor.SubFolders
                AraVeListele altKlasor.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
            Next altKlasor
        End If
    Else
        For Each altKlasor In klasor.SubFolders
            If fso.FolderExists(altKlasor.Path) Then
                Set klasor2 = fso.GetFolder(altKlasor.Path)
                For Each altKlasor2 In klasor2.SubFolders
                    AraVeListele altKlasor2.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci
                Next altKlasor2
            End If
        Next altKlasor
    End If
  
    sonucSayfasi.Cells(satirSayaci, 3).Value = "TOPLAM:"
    sonucSayfasi.Cells(satirSayaci, 4).Value = toplamTutar
    sonucSayfasi.Cells(satirSayaci, 4).NumberFormat = "#,##0.00 ₺"
    sonucSayfasi.Cells(satirSayaci, 3).Font.Bold = True
    sonucSayfasi.Cells(satirSayaci, 4).Font.Bold = True
    sonucSayfasi.Columns("A:D").AutoFit
  
    Application.StatusBar = False
    Application.ScreenUpdating = True
  
    MsgBox "Arama tamamlandı!" & vbCrLf & _
           "İncelenen Dosya Sayısı: " & bulunanDosyalar & vbCrLf & _
           "Bulunan Satır Sayısı: " & bulunanSatirlar & vbCrLf & _
           "Toplam Tutar: " & Format(toplamTutar, "#,##0.00 ₺"), vbInformation, "Arama Sonuçları"
End Sub

Sub AraVeListele(klasorYolu As String, arananKelime As String, sonucSayfasi As Worksheet, ByRef bulunanDosyalar As Integer, ByRef bulunanSatirlar As Integer, ByRef toplamTutar As Double, ByRef satirSayaci As Integer)
    Dim fso As Object
    Dim klasor As Object
    Dim dosya As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim sonSatir As Integer
    Dim dosyaYolu As String
  
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set klasor = fso.GetFolder(klasorYolu)
  
    For Each dosya In klasor.Files
        If LCase(Right(dosya.Name, 4)) = ".xls" Or LCase(Right(dosya.Name, 5)) = ".xlsx" Or LCase(Right(dosya.Name, 5)) = ".xlsm" Then
            dosyaYolu = dosya.Path
            Application.StatusBar = "İnceleniyor: " & dosya.Name
          
            On Error Resume Next
            Set wb = Workbooks.Open(dosyaYolu, ReadOnly:=True, UpdateLinks:=False)
            On Error GoTo 0
          
            If Not wb Is Nothing Then
                bulunanDosyalar = bulunanDosyalar + 1
                Set ws = wb.Sheets(1)
                sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                For i = 6 To 31
                    If i > sonSatir Then Exit For
                  
                    If InStr(1, LCase(ws.Cells(i, 1).Value), LCase(arananKelime), vbTextCompare) > 0 Then
                        Dim tutar As Double
                        tutar = 0
                      
                        If IsNumeric(ws.Cells(i, 3).Value) Then
                            tutar = CDbl(ws.Cells(i, 3).Value)
                            sonucSayfasi.Cells(satirSayaci, 1).Value = dosya.Name
                            sonucSayfasi.Cells(satirSayaci, 2).Value = i
                            sonucSayfasi.Cells(satirSayaci, 3).Value = ws.Cells(i, 1).Value
                            sonucSayfasi.Cells(satirSayaci, 4).Value = tutar
                            sonucSayfasi.Cells(satirSayaci, 4).NumberFormat = "#,##0.00 ₺"
                            bulunanSatirlar = bulunanSatirlar + 1
                            toplamTutar = toplamTutar + tutar
                            satirSayaci = satirSayaci + 1
                        End If
                    End If
                Next i
                wb.Close SaveChanges:=False
            End If
        End If
    Next dosya
End Sub
Genişletmek için tıkla ...
2018 klasörüne uyguladığımda tüm aylar için listele dediğimde kod sorunsuz çalışmıştı.

Fakat diğer klasörlerde denediğimde tüm ayları listele dediğimde automation error hatası alıyorum. İlginç bir şekilde 2019-2020-2021-2022 klasörülerinde ay seçmeden arama yaptığımda sol altta inceleniyor kısmına bakıyorum aralık (01.12.xxxx) itibariyle arama gerçekleştiriyor. Sadece 2018 klasöründe tüm ayları tarayabiliyor.

İlgili klasörü seçip ilgili ayı seçtiğim zaman kod çalışıyor. Sorun ne olabilir ?
 
Son düzenleme:
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
335
Excel Vers. ve Dili
Excel 2021 Türkçe
Merhaba tekrardan, şu şekilde kodu güncelleyip yedek aldıktan sonra deneyebilir misiniz;

Kod: 
Sub KelimeAramaVeToplama()
    Dim anaKlasor As String
    Dim yilKlasor As String
    Dim ayKlasor As String
    Dim dosya As String
    Dim arananKelime As String
    Dim bulunanDosyalar As Integer
    Dim bulunanSatirlar As Integer
    Dim toplamTutar As Double
    Dim sonSatir As Integer
    Dim i As Integer
    Dim sonucSayfasi As Worksheet
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim secimYil As Boolean
    Dim secimAy As Boolean
    Dim fso As Object
    Dim klasor As Object
    Dim altKlasor As Object
    Dim dosyaNesne As Object
    Dim satirSayaci As Integer
    Dim aramaKolon As String
    Dim metinKolon As String
    Dim tutarKolon As String
  
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Ana Klasörü Seçin (Yıl klasörleri bulunan klasör)"
        .AllowMultiSelect = False
        If .Show = -1 Then
            anaKlasor = .SelectedItems(1)
        Else
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
    End With
  
    arananKelime = InputBox("Aranacak kelimeyi girin:", "Kelime Ara", "banka")
    If arananKelime = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
    
    aramaKolon = InputBox("Hangi sütunda arama yapmak istiyorsunuz? (A, B, C...)", "Sütun Seçimi", "F")
    If aramaKolon = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
    
    metinKolon = InputBox("Metin içeriğini hangi sütundan almak istiyorsunuz? (A, B, C...)", "Metin Sütunu Seçimi", "G")
    If metinKolon = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
    
    tutarKolon = InputBox("Tutar değerini hangi sütundan almak istiyorsunuz? (A, B, C...)", "Tutar Sütunu Seçimi", "H")
    If tutarKolon = "" Then
        MsgBox "İşlem iptal edildi.", vbInformation
        Exit Sub
    End If
  
    secimYil = MsgBox("Belirli bir yıl için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
  
    If secimYil Then
        yilKlasor = InputBox("Hangi yıl için arama yapmak istiyorsunuz? (ör: 2018)", "Yıl Seçimi")
        If yilKlasor = "" Then
            MsgBox "İşlem iptal edildi.", vbInformation
            Exit Sub
        End If
      
        If Not fso.FolderExists(anaKlasor & "\" & yilKlasor) Then
            MsgBox "Belirtilen yıl klasörü bulunamadı: " & yilKlasor, vbExclamation
            Exit Sub
        End If
      
        secimAy = MsgBox("Belirli bir ay için mi arama yapmak istiyorsunuz?", vbYesNo) = vbYes
      
        If secimAy Then
            ayKlasor = InputBox("Hangi ay için arama yapmak istiyorsunuz? (ör: OCAK)", "Ay Seçimi")
            If ayKlasor = "" Then
                MsgBox "İşlem iptal edildi.", vbInformation
                Exit Sub
            End If
          
            If Not fso.FolderExists(anaKlasor & "\" & yilKlasor & "\" & ayKlasor) Then
                MsgBox "Belirtilen ay klasörü bulunamadı: " & ayKlasor, vbExclamation
                Exit Sub
            End If
        End If
    End If
  
    Set sonucSayfasi = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    sonucSayfasi.Name = "Arama_Sonuclari_" & Format(Now(), "yyyymmdd_hhmmss")
    sonucSayfasi.Cells(1, 1).Value = "Dosya Adı"
    sonucSayfasi.Cells(1, 2).Value = "İçerik"
    sonucSayfasi.Cells(1, 3).Value = "Tutar"
    bulunanDosyalar = 0
    bulunanSatirlar = 0
    toplamTutar = 0
    satirSayaci = 2
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "Dosyalar aranıyor..."
    Set klasor = fso.GetFolder(anaKlasor)
  
    If secimYil Then
        If secimAy Then
            AraVeListele anaKlasor & "\" & yilKlasor & "\" & ayKlasor, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci, aramaKolon, metinKolon, tutarKolon
        Else
            Set klasor = fso.GetFolder(anaKlasor & "\" & yilKlasor)
            For Each altKlasor In klasor.SubFolders
                On Error Resume Next
                AraVeListele altKlasor.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci, aramaKolon, metinKolon, tutarKolon
                On Error GoTo 0
            Next altKlasor
        End If
    Else
        For Each altKlasor In klasor.SubFolders
            On Error Resume Next
            If fso.FolderExists(altKlasor.Path) Then
                Set klasor2 = fso.GetFolder(altKlasor.Path)
                For Each altKlasor2 In klasor2.SubFolders
                    AraVeListele altKlasor2.Path, arananKelime, sonucSayfasi, bulunanDosyalar, bulunanSatirlar, toplamTutar, satirSayaci, aramaKolon, metinKolon, tutarKolon
                Next altKlasor2
            End If
            On Error GoTo 0
        Next altKlasor
    End If
  
    sonucSayfasi.Cells(satirSayaci, 2).Value = "TOPLAM:"
    sonucSayfasi.Cells(satirSayaci, 3).Value = toplamTutar
    sonucSayfasi.Cells(satirSayaci, 3).NumberFormat = "#,##0.00 ₺"
    sonucSayfasi.Cells(satirSayaci, 2).Font.Bold = True
    sonucSayfasi.Cells(satirSayaci, 3).Font.Bold = True
    sonucSayfasi.Columns("A:C").AutoFit
    
    If satirSayaci > 2 Then
        sonucSayfasi.Range("A2:C" & satirSayaci - 1).Sort _
            Key1:=sonucSayfasi.Range("A2"), Order1:=xlAscending, _
            Header:=xlNo
    End If
  
    Application.StatusBar = False
    Application.ScreenUpdating = True
  
    MsgBox "Arama tamamlandı!" & vbCrLf & _
           "İncelenen Dosya Sayısı: " & bulunanDosyalar & vbCrLf & _
           "Bulunan Satır Sayısı: " & bulunanSatirlar & vbCrLf & _
           "Toplam Tutar: " & Format(toplamTutar, "#,##0.00 ₺"), vbInformation, "Arama Sonuçları"
End Sub

Sub AraVeListele(klasorYolu As String, arananKelime As String, sonucSayfasi As Worksheet, ByRef bulunanDosyalar As Integer, ByRef bulunanSatirlar As Integer, ByRef toplamTutar As Double, ByRef satirSayaci As Integer, aramaKolon As String, metinKolon As String, tutarKolon As String)
    Dim fso As Object
    Dim klasor As Object
    Dim dosya As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim sonSatir As Integer
    Dim dosyaYolu As String
    Dim aramaKolonNum As Integer
    Dim metinKolonNum As Integer
    Dim tutarKolonNum As Integer
    
    aramaKolonNum = Asc(UCase(aramaKolon)) - 64
    metinKolonNum = Asc(UCase(metinKolon)) - 64
    tutarKolonNum = Asc(UCase(tutarKolon)) - 64
  
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set klasor = fso.GetFolder(klasorYolu)
    If Err.Number <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
  
    For Each dosya In klasor.Files
        If LCase(Right(dosya.Name, 4)) = ".xls" Or LCase(Right(dosya.Name, 5)) = ".xlsx" Or LCase(Right(dosya.Name, 5)) = ".xlsm" Then
            dosyaYolu = dosya.Path
            Application.StatusBar = "İnceleniyor: " & dosya.Name
          
            On Error Resume Next
            Set wb = Workbooks.Open(dosyaYolu, ReadOnly:=True, UpdateLinks:=False)
            
            If Err.Number <> 0 Then
                Err.Clear
                On Error GoTo 0
                Resume Next
            End If
            On Error GoTo 0
          
            If Not wb Is Nothing Then
                bulunanDosyalar = bulunanDosyalar + 1
                
                On Error Resume Next
                Set ws = wb.Sheets(1)
                If Err.Number <> 0 Then
                    Err.Clear
                    wb.Close SaveChanges:=False
                    On Error GoTo 0
                    Resume Next
                End If
                On Error GoTo 0
                
                sonSatir = ws.Cells(ws.Rows.Count, aramaKolonNum).End(xlUp).Row
                If sonSatir < 6 Then sonSatir = 6
                
                For i = 6 To 31
                    If i > sonSatir Then Exit For
                  
                    On Error Resume Next
                    If InStr(1, LCase(ws.Cells(i, aramaKolonNum).Value), LCase(arananKelime), vbTextCompare) > 0 Then
                        Dim tutar As Double
                        tutar = 0
                        
                        If IsNumeric(ws.Cells(i, tutarKolonNum).Value) Then
                            tutar = CDbl(ws.Cells(i, tutarKolonNum).Value)
                            sonucSayfasi.Cells(satirSayaci, 1).Value = dosya.Name
                            sonucSayfasi.Cells(satirSayaci, 2).Value = ws.Cells(i, metinKolonNum).Value
                            sonucSayfasi.Cells(satirSayaci, 3).Value = tutar
                            sonucSayfasi.Cells(satirSayaci, 3).NumberFormat = "#,##0.00 ₺"
                            bulunanSatirlar = bulunanSatirlar + 1
                            toplamTutar = toplamTutar + tutar
                            satirSayaci = satirSayaci + 1
                        End If
                    End If
                    On Error GoTo 0
                Next i
                wb.Close SaveChanges:=False
            End If
        End If
    Next dosya
End Sub

Function DosyaAdiTarihiAl(dosyaAdi As String) As Date
    On Error Resume Next
    Dim tarihStr As String
    Dim gun As Integer
    Dim ay As Integer
    Dim yil As Integer
    
    tarihStr = Left(dosyaAdi, 10)
    gun = Val(Left(tarihStr, 2))
    ay = Val(Mid(tarihStr, 4, 2))
    yil = Val(Mid(tarihStr, 7, 4))
    
    If gun > 0 And ay > 0 And yil > 0 Then
        DosyaAdiTarihiAl = DateSerial(yil, ay, gun)
    Else
        DosyaAdiTarihiAl = DateSerial(1900, 1, 1) ' Varsayılan tarih
    End If
    On Error GoTo 0
End Function
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst