Klasör içindeki kapalı excellerden sorgu !

[Korhan Ayhan]

Veri alınacak örnek dosyada paylaşır mısınız?

 

[asas44]

Veri alınacak örnek dosyada paylaşır mısınız?

Buyurun hocam;
https://dosya.co/nmynrih6dplt/DENEME.rar.html

 

[asas44]

Sub veri_al10()
Sheets("veri").Cells.ClearContents

Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Rows("3:" & Rows.Count).Interior.ColorIndex = xlNone
Liste10 (ThisWorkbook.Path)
MsgBox "işlem tamam"
   
End Sub

Private Sub Liste10(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


aranan_Uzanti = fL.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fL.GetFolder(Yol).Files

If ThisWorkbook.Name = dosya.Name Then
GoTo atla1
End If

If "~$" = Mid(dosya.Name, 1, 2) Then
GoTo atla1
End If


uzanti = fL.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoTo atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoTo atla1
Else
End If
End If


Dim Kayit As ADODB.Recordset
Set Kayit = New ADODB.Recordset



Dosya_adi = fL.GetBaseName(dosya)
uzanti = fL.GetExtensionName(dosya)

Sayfa_adı = "ANA SAYFA"

If uzanti = "xls" Then
baglan = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
Kayit.Open "SELECT * FROM [" & Sayfa_adı & "$] ", baglan, adOpenKeyset, adLockOptimistic
ElseIf uzanti = "xlsb" Or uzanti = "xlsx" Or uzanti = "xlsm" Then
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007
Kayit.Open "SELECT * FROM [" & Sayfa_adı & "$] ", baglan, adOpenKeyset, adLockOptimistic
Else
End If
'strSQL = "SELECT COUNT(*) from [SourceData$A1:IV6] S"
'strSQL = "SELECT S.FIELD_NAME1,S.FIELD_NAME2,S.FIELD_NAME3 from [SourceData$A1:IV6] S"



If Kayit.RecordCount > 0 Then
Sheets("veri").Range("A1").CopyFromRecordset Kayit
Sheets("veri").Range("O1:O" & Kayit.RecordCount).Value = dosya.Name
bul_Click2
Sheets("veri").Cells.ClearContents
End If



Kayit.Close
Set Kayit = Nothing

atla1:
Next


On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste10 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Sub bul_Click2()

For m = 1 To 14
ad = Cells(2, m)

If ad = "" Then GoTo atla1

Set Sh = Sheets("veri")
yer = xlFormulas
yer1 = xlPart

If WorksheetFunction.CountA(Sh.Cells) > 0 Then
sat = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Else
Exit Sub
End If

If WorksheetFunction.CountA(Cells) > 0 Then
sonsat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
End If
If sonsat < 3 Then sonsat = 3


Dim SütunAdı As String
SütunAdı = Split(Sh.Cells(1, Val(m)).Address, "$")(1)

For k = 2 To sat

With Sh.Range(SütunAdı & k & ":" & SütunAdı & k)

'With Sh.Range("A" & k & ":N" & k)
Set d = .Find(What:=ad, After:=.Cells(.Cells.Count), LookIn:=yer, lookat:=yer1, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do

For r = 1 To 15
Cells(sonsat, r) = Sh.Cells(d.Row, r)
Next
Cells(sonsat, 16) = d.Row + 1
Cells(sonsat, d.Column).Interior.Color = 65535
sonsat = sonsat + 1

Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If

End With
Next
atla1:
Next m
Set Sh = Nothing
End Sub

Konu güncel arayan ve aranan excel sayfa isimleri ANA SAYFA olarak sabitlenmiş sorunum sayfa ismine bakmaksızın arama yapması üst msj da örnek veride yükledim uğraştım ama yapamadım fikri olan varmı acaba ?

 

[Korhan Ayhan]

2. satıra aranan veriyi girip deneyiniz.

Tüm dosyalarınız aynı klasörde olacak şekilde düzenledim.

 

[asas44]

2. satıra aranan veriyi girip deneyiniz.

Tüm dosyalarınız aynı klasörde olacak şekilde düzenledim.

Hocam dosyayı indiremiyorum kod paylaşırsanız yada dosya paylaşımı yaparsanız çok sevinirim

 

[Korhan Ayhan]

Harici Link (Silinebilir) ; https://s7.dosya.tc/server17/ezz5y7/SORGU_DOSYASI.xlsm.html

 

[asas44]

Hocam elinize sağlık sayfa ismi farketmeden arama yapıyor veriyi getiriyor deneme maksatlı 3 tane sayfa açıp denediğimde;
Application-defined or object-defined error hatası veriyor ( aranan veri olmadığında da aynı)
kod içerisinde ise S1.Cells(Son, "O").Resize(Kayit_Seti.RecordCount) = Dosya bu kısmı sarı yakıyor

 

[Korhan Ayhan]

Dosyalar aynı klasör içinde olmalıdır.

 

[asas44]

Dosyalar aynı klasör içinde olmalıdır.

Doğrudur hocam aynı klasör içindeler ama yinede bu hatayı verdi

 

[Korhan Ayhan]

Paylaşın bakalım.

 

[asas44]

Paylaşın bakalım.

Buyurun hocam https://dosya.co/bji5bdpwo5n6/deneme.rar.html

 

[Korhan Ayhan]

Sayısal veri arama durumunuz olacak mı?

 

[asas44]

Sayısal veri arama durumunuz olacak mı?

Hatada sayısal aramamıştım ama illaki olur tarih te aranabilir sayısal veride

 

[Korhan Ayhan]

Kullandığımız yöntemde sayısal alanların belli olması bize avantaj sağlayacaktır. Öbür türlü bütün verileri METİN formatında alabiliriz.

 

[asas44]

Sütun çok fazla sayısal veri sütunları sizi yorar sadece hata giderilse yeter hocam hatayı zaten metin aramasında aldım gerekirse sayısal arama yapmam

 

[Korhan Ayhan]

Üstte ki mesajımda ki dosyaları revize ettim. Deneyiniz.

 

[asas44]

Hocam çok teşekkür ederim ellerinize sağlık gayet iyi çalışıyor sık ziyaret ve bol reklam tıkı ile müteşekkirim iyi çalışmalar