Klasör içindeki kapalı excellerden sorgu !

Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Herkeze kolay gelsin ustalarım aşamadığım bir konu oldu ve yardımınız gerekiyor.
şu şekilde özetleyeyim;elimde bir ana sorgu sayfam var bunda texbox lar bulundukları sayfada bulundukları sütunları tarayıp süzmektedir her texbox farklı çalışıyor kimi eşittir bakıyor kimi içinde bakıyor buraya kadar sorun yok. benim sorum şu; bu sayfa boş olacak ana sorgu dosyası olarak kullanılacak aynı bu sayfadaki veriler gibi değişken veriler içeren bir klasörün içerisinde birden fazla excel sayfaları bulunmakta, ben bu texboxlardan arama işlemi yaptığım zaman belirttiğim klasör içerisinde kapalı excel dosyalarından sorgu yapıp bulduğu değerleri satırı ile birlikte getirip yerlerine yazmasını istiyorum.
Eminim herkezin işine yarayacak bir çalışma olur yardımlarınız için şimdiden çok teşekkür ediyorum
Örnek dosya aşağıdadır:

http://s9.dosya.tc/server2/adzo75/DATA_DOSYASI.rar.html
 
Son düzenleme:
Katılım
5 Nisan 2007
Mesajlar
32
Excel Vers. ve Dili
2003 türkçe
Bende çok fazla aradım buna benzer bir durumum vardı kapalı bir excell dosyasından istediğim satır aralığını dosyayı hiç açmadan kopyalamak ve ana dosyamda istediğim yere yapıştırmayı ama malesef bulamadım.
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Konu günceldir. tahminim herkezin işine yarayacak birşey olur
 

Erdem Akdemir

Destek Ekibi
Destek Ekibi
Katılım
4 Mayıs 2007
Mesajlar
3,596
Excel Vers. ve Dili
2016 PRO TÜRKÇE-İNG. 64 BİT
Merhaba,

ADO konusunu inceleyiniz.
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Merhaba,

ADO konusunu inceleyiniz.
ADO konusunu inceledim fakat hem linklerden hemde konuya çok fazla vakıf olmadığım için işin içinden çıkamadım. Anlayan hocalarımdan sadece bir sütun için destek alırsak en azından diğerlerini yorumlama şansımız doğar diye düşündüm. Konu günceldir inşallah imkansız değildir talebimiz...
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,316
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Lütfen ilk mesajınızı forum kurallarına göre düzenleyiniz!

Forumda cümlenin tamamında büyük harf kullanımı uygun değildir.
 

Erdem Akdemir

Destek Ekibi
Destek Ekibi
Katılım
4 Mayıs 2007
Mesajlar
3,596
Excel Vers. ve Dili
2016 PRO TÜRKÇE-İNG. 64 BİT
dosyanızı google drive'a yükleyerek indirme linkini paylaşabilir misiniz.
 

Erdem Akdemir

Destek Ekibi
Destek Ekibi
Katılım
4 Mayıs 2007
Mesajlar
3,596
Excel Vers. ve Dili
2016 PRO TÜRKÇE-İNG. 64 BİT
Merhaba,

Sorunuzu hem anlamadım,hemde bana biraz uzun bir islem gibi geldi.Daha sade bir dosya eklerseniz bakabilirim.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Aranan verileri text nesnesine değilde birinci satıra yazarak bu kodu çalıştırın.

Kod:
Dim sat9

Sub veri_al()

b = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo) 'Mesaj.İsteğe bağlı yazılmayabilir.
If b = vbYes Then
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).ClearContents

End If


sat9 = 3
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path

If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

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

If sat9 < 3 Then sat9 = 3

deger1 = Cells(1, 21)
deger2 = Cells(1, 22)
deger3 = Cells(1, 23)
deger4 = Cells(1, 24)
deger5 = Cells(1, 25)


Liste9 (Klasor.Items.Item.Path)

Cells(1, 21) = deger1
Cells(1, 22) = deger2
Cells(1, 23) = deger3
Cells(1, 24) = deger4
Cells(1, 25) = deger5

Cells(1, 15) = "Satır no"
Cells(1, 16) = "Sayfa Adı"
Cells(1, 17) = "Dopsya Adı"

MsgBox "işlem tamam"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste9(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fs = CreateObject("Scripting.FileSystemObject")

ReDim yer(100)

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

For Each Dosya In fs.GetFolder(yol).Files

If ThisWorkbook.Name = Dosya.Name Then
GoTo Atla2
End If

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


Uzanti = fs.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


If ThisWorkbook.Name <> Dosya.Name Then
For kak = 1 To 100
yer(kak) = ""
Next


say1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")

Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya & ";"
Katalog.ActiveConnection = Data

For Each Tablo In Katalog.Tables

If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")


If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

son1 = Left$(son1, Len(son1) - 1)

deg = Split(son1, "#")
son = UBound(deg)

If son = 0 Then
Else
say1 = say1 + 1
yer(say1) = Replace(son1, "#", ".")
End If

say1 = say1 + 1
yer(say1) = son1
End If
End If


End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing

Kalasor2 = fs.GetParentFolderName(Dosya)

If Right(Kalasor2, 1) <> "\" Then Kalasor2 = Kalasor2 & "\"
Cells(1, 22).Value = fs.GetFileName(Dosya)


For mat = 1 To say1

SayfaAdi = yer(mat)
Cells(1, 23).Value = SayfaAdi

deg2 = Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi
deg3 = "'" & Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi & "'!R"

sonsat = Rows.Count - 1


son1 = 0
son2 = 0

'---------------------------------------------------------------------------------------

kap_dos_sütün_no = Split(Cells(1, 1).Address, "$")(1)
kap_dos_satir_no = Cells(1, 1).Row

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(1, 24).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
'Cells(1,24).Value = Cells(1,24).Value
son1 = Cells(1, 24).Value ' Kapalı dosyaya ait son dolu sütun sayısı

yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(1, 25).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"

son2 = Cells(1, 25).Value ' Kapalı dosyaya ait son dolu satır sayısı
Cells(1, 24).Value = son1
Cells(1, 25).Value = son2
sut1 = Cells(1, 24).Value ' Kapalı dosyaya ait son dolu sütun sayısı
sat1 = Cells(1, 25).Value ' Kapalı dosyaya ait son dolu satır sayısı

bas_satir_no = 1 'Cells(Rows.Count, "A").End(3).Row + 1

For r = 3 To sat1 ' Kapalı dosyaya ait son dolu satır sayısı

For t = 1 To 14
If Cells(bas_satir_no, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t) Then 'kapalı dosyadaki değerlere ait prosüdür
Cells(sat9, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t)  'kapalı dosyadaki değerlere ait prosüdür
End If


Next t

If WorksheetFunction.CountA(Range(Cells(sat9, "a"), Cells(sat9, "n"))) > 0 Then
Cells(sat9, 15).Value = r
Cells(sat9, 16).Value = SayfaAdi
Cells(sat9, 17).Value = Dosya.Name
sat9 = sat9 + 1
End If


Next r

Atla1:
Next mat

End If

Atla2:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste9 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod da bulunan değerleri hücrede renklendiriyor.

Kod:
Dim sat9

Sub veri_al()

b = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo) 'Mesaj.İsteğe bağlı yazılmayabilir.
If b = vbYes Then
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Rows("3:" & Rows.Count).Interior.ColorIndex = xlNone
End If


sat9 = 3
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path

If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

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

If sat9 < 3 Then sat9 = 3

deger1 = Cells(1, 21)
deger2 = Cells(1, 22)
deger3 = Cells(1, 23)
deger4 = Cells(1, 24)
deger5 = Cells(1, 25)


Liste9 (Klasor.Items.Item.Path)

Cells(1, 21) = deger1
Cells(1, 22) = deger2
Cells(1, 23) = deger3
Cells(1, 24) = deger4
Cells(1, 25) = deger5

Cells(1, 15) = "Satır no"
Cells(1, 16) = "Sayfa Adı"
Cells(1, 17) = "Dopsya Adı"

MsgBox "işlem tamam"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste9(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fs = CreateObject("Scripting.FileSystemObject")

ReDim yer(100)

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

For Each Dosya In fs.GetFolder(yol).Files

If ThisWorkbook.Name = Dosya.Name Then
GoTo Atla2
End If

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


Uzanti = fs.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


If ThisWorkbook.Name <> Dosya.Name Then
For kak = 1 To 100
yer(kak) = ""
Next


say1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")

Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya & ";"
Katalog.ActiveConnection = Data

For Each Tablo In Katalog.Tables

If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")


If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

son1 = Left$(son1, Len(son1) - 1)

deg = Split(son1, "#")
son = UBound(deg)

If son = 0 Then
Else
say1 = say1 + 1
yer(say1) = Replace(son1, "#", ".")
End If

say1 = say1 + 1
yer(say1) = son1
End If
End If


End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing

Kalasor2 = fs.GetParentFolderName(Dosya)

If Right(Kalasor2, 1) <> "\" Then Kalasor2 = Kalasor2 & "\"
Cells(1, 22).Value = fs.GetFileName(Dosya)


For mat = 1 To say1

SayfaAdi = yer(mat)
Cells(1, 23).Value = SayfaAdi

deg2 = Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi
deg3 = "'" & Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi & "'!R"

sonsat = Rows.Count - 1


son1 = 0
son2 = 0

'---------------------------------------------------------------------------------------

kap_dos_sütün_no = Split(Cells(1, 1).Address, "$")(1)
kap_dos_satir_no = Cells(1, 1).Row

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(1, 24).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
'Cells(1,24).Value = Cells(1,24).Value
son1 = Cells(1, 24).Value ' Kapalı dosyaya ait son dolu sütun sayısı

yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(1, 25).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"

son2 = Cells(1, 25).Value ' Kapalı dosyaya ait son dolu satır sayısı
Cells(1, 24).Value = son1
Cells(1, 25).Value = son2
sut1 = Cells(1, 24).Value ' Kapalı dosyaya ait son dolu sütun sayısı
sat1 = Cells(1, 25).Value ' Kapalı dosyaya ait son dolu satır sayısı

bas_satir_no = 1 'Cells(Rows.Count, "A").End(3).Row + 1

For r = 3 To sat1 ' Kapalı dosyaya ait son dolu satır sayısı
deg1 = 0
For t = 1 To 14
If Cells(bas_satir_no, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t) Then 'kapalı dosyadaki değerlere ait prosüdür
'Cells(sat9, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t)  'kapalı dosyadaki değerlere ait prosüdür
Cells(sat9, t).Interior.Color = 65535
    
deg1 = 1
'Exit For
End If
Next t

If deg1 = 1 Then
For t = 1 To 14
Cells(sat9, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t)  'kapalı dosyadaki değerlere ait prosüdür
Next t
Cells(sat9, 15).Value = r
Cells(sat9, 16).Value = SayfaAdi
Cells(sat9, 17).Value = Dosya.Name
sat9 = sat9 + 1
End If

If WorksheetFunction.CountA(Range(Cells(sat9, "a"), Cells(sat9, "n"))) > 0 Then

End If


Next r

Atla1:
Next mat

End If

Atla2:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste9 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Halit hocam öncelikle çok teşekkür ederim buda işimi görür fakat bir kaç düzeltme olması mümkünmü acaba
Örneğin değer aynısı ise getiriyor yani küçük büyük harf göz önünde bulunduruyor Ali yi arıyorum ALİ yi bulmuyor
Hedef klasör manuel değilde sabit seçilse örneğin C:\Users\PC\Desktop\DATA Gibi ben atayabilsem
Birde sorgu yapacağım dosyalar çok yoğun aramayı hızlandırabilirmiyiz
Birde 1. satır değilde 2. satırda yazdığımı araması mümkünmü acaba
 
Son düzenleme:

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod:

Kod:
Dim sat9

Sub veri_al6()

b = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo) 'Mesaj.İsteğe bağlı yazılmayabilir.
If b = vbYes Then
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Rows("3:" & Rows.Count).Interior.ColorIndex = xlNone
End If

sat9 = 3


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

If sat9 < 3 Then sat9 = 3

deger1 = Cells(1, 21)
deger2 = Cells(1, 22)
deger3 = Cells(1, 23)
deger4 = Cells(1, 24)
deger5 = Cells(1, 25)


Liste9 ([COLOR="red"]ThisWorkbook.Path[/COLOR])

Cells(1, 21) = deger1
Cells(1, 22) = deger2
Cells(1, 23) = deger3
Cells(1, 24) = deger4
Cells(1, 25) = deger5

Cells(1, 15) = "Satır no"
Cells(1, 16) = "Sayfa Adı"
Cells(1, 17) = "Dopsya Adı"

MsgBox "işlem tamam"


    
End Sub
 
Private Sub Liste9(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fs = CreateObject("Scripting.FileSystemObject")

ReDim yer(100)

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

For Each Dosya In fs.GetFolder(yol).Files

If ThisWorkbook.Name = Dosya.Name Then
GoTo Atla2
End If

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


Uzanti = fs.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


If ThisWorkbook.Name <> Dosya.Name Then
For kak = 1 To 100
yer(kak) = ""
Next


say1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")

Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya & ";"
Katalog.ActiveConnection = Data

For Each Tablo In Katalog.Tables

If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")


If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

son1 = Left$(son1, Len(son1) - 1)

deg = Split(son1, "#")
son = UBound(deg)

If son = 0 Then
Else
say1 = say1 + 1
yer(say1) = Replace(son1, "#", ".")
End If

say1 = say1 + 1
yer(say1) = son1
End If
End If


End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing

Kalasor2 = fs.GetParentFolderName(Dosya)

If Right(Kalasor2, 1) <> "\" Then Kalasor2 = Kalasor2 & "\"
Cells(1, 22).Value = fs.GetFileName(Dosya)


For mat = 1 To say1

SayfaAdi = yer(mat)
Cells(1, 23).Value = SayfaAdi

deg2 = Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi
deg3 = "'" & Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi & "'!R"

sonsat = Rows.Count - 1


son1 = 0
son2 = 0

'---------------------------------------------------------------------------------------

kap_dos_sütün_no = Split(Cells(1, 1).Address, "$")(1)
kap_dos_satir_no = Cells(1, 1).Row

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(1, 24).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
'Cells(1,24).Value = Cells(1,24).Value
son1 = Cells(1, 24).Value ' Kapalı dosyaya ait son dolu sütun sayısı

yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(1, 25).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"

son2 = Cells(1, 25).Value ' Kapalı dosyaya ait son dolu satır sayısı
Cells(1, 24).Value = son1
Cells(1, 25).Value = son2
sut1 = Cells(1, 24).Value ' Kapalı dosyaya ait son dolu sütun sayısı
sat1 = Cells(1, 25).Value ' Kapalı dosyaya ait son dolu satır sayısı

bas_satir_no=[COLOR="Red"] 2[/COLOR] 'Cells(Rows.Count, "A").End(3).Row + 1

For r = 3 To sat1 ' Kapalı dosyaya ait son dolu satır sayısı
deg1 = 0
For t = 1 To 14
[COLOR="Red"]If LCase(Replace(Replace(Cells(bas_satir_no, t).Value, "I", "ı"), "İ", "i")) = LCase(Replace(Replace(ExecuteExcel4Macro(deg3 & r & "C" & t), "I", "ı"), "İ", "i")) Then 'kapalı dosyadaki değerlere ait prosüdür[/COLOR]

'If LCase(Cells(bas_satir_no, t).Value) = LCase(ExecuteExcel4Macro(deg3 & r & "C" & t)) Then 'kapalı dosyadaki değerlere ait prosüdür
'Cells(sat9, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t)  'kapalı dosyadaki değerlere ait prosüdür
Cells(sat9, t).Interior.Color = 65535

deg1 = 1
'Exit For
End If
Next t

If deg1 = 1 Then
For t = 1 To 14
Cells(sat9, t).Value = ExecuteExcel4Macro(deg3 & r & "C" & t)  'kapalı dosyadaki değerlere ait prosüdür
Next t
Cells(sat9, 15).Value = r
Cells(sat9, 16).Value = SayfaAdi
Cells(sat9, 17).Value = Dosya.Name
sat9 = sat9 + 1
End If

If WorksheetFunction.CountA(Range(Cells(sat9, "a"), Cells(sat9, "n"))) > 0 Then

End If


Next r

Atla1:
Next mat

End If

Atla2:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste9 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Halit hocam Allah razı olsun ellerinize sağlık ;
Hem aranan dedeğin bir harfi küçük yada büyük olsa bulmuyor, hemde arama yaptığım sayfalar 700 er 800 er satırlardan oluşuyor ilk dosyadan çıkamıyor 1 saat kadar oldu hala arıyor :(
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Halit hocam Allah razı olsun ellerinize sağlık ;
Hem aranan dedeğin bir harfi küçük yada büyük olsa bulmuyor, hemde arama yaptığım sayfalar 700 er 800 er satırlardan oluşuyor ilk dosyadan çıkamıyor 1 saat kadar oldu hala arıyor :(
Türkçe karekter sorunundan kaynaklanıyor yukarıdaki mesajdaki kodu düzelttim.


Buuygulama birazcık yavaş çalışır.
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Türkçe karekter sorunundan kaynaklanıyor yukarıdaki mesajdaki kodu düzelttim.


Buuygulama birazcık yavaş çalışır.
Halit hocam ellerinize sağlık tek sıkıntı hız olayı şuan aradığım veri saatler sürüyor atıyorum 1m satırlık 5 dosyadan arama yapmaya kalktım mecbur durdurmak zorunda kalıyorum. Öneriniz varmı hız konusunda ?
 
Katılım
27 Şubat 2008
Mesajlar
306
Excel Vers. ve Dili
Office 2016
Aynı sorun bende oldu ben olayı şu şekilde çözdüm çalışma kitabından yeni bir sayfaya diğer çalışma kitabındaki sayfayı kopyala yapıştır yaparak, aynı çalışma kitabı içerisinde arama yaptırdım. Bu şekilde arama çok daha hızlı oluyor.
Aramanızı sadece bir sutuna göremi yapacaksınız yoksa herhangi bir sutuna yazabilirmisizniz (Mesala sadece faks sutununumu doldurup diğerlerinin otomatik dolmasını isteyeceksiniz. ) Birde tekrarlayan değer varmı aramada faks numarasından birden fazla varmı
 
Son düzenleme:
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Aynı sorun bende oldu ben olayı şu şekilde çözdüm çalışma kitabından yeni bir sayfaya diğer çalışma kitabındaki sayfayı kopyala yapıştır yaparak, aynı çalışma kitabı içerisinde arama yaptırdım. Bu şekilde arama çok daha hızlı oluyor.
Aramanızı sadece bir sutuna göremi yapacaksınız yoksa herhangi bir sutuna yazabilirmisizniz (Mesala sadece faks sutununumu doldurup diğerlerinin otomatik dolmasını isteyeceksiniz. ) Birde tekrarlayan değer varmı aramada faks numarasından birden fazla varmı
Benim tek sayfada toplama şansım yok her bir dosya 800-900 bin satırdan oluşuyor verilerin toplamı 4-5 m satırı bulur. veriler mükerrer de içeriyor değişkende ben fax satırına numarayı yazdığım zaman bulduğu numaranın satırı ile beraber getirmesi gerekiyor
 
Üst