Birden fazla excell dosyasi arasinda arama yapmak

S

sefayksl

Katılım
11 Haziran 2016
Mesajlar
25
Excel Vers. ve Dili
Office 2010
English
Altın Üyelik Bitiş Tarihi
26/02/2019
Merhabalar,

Malzeme cikislari icin kullandigimiz excell formlarinin hepsinde toplu arama yapmam gerekiyor. Yani bir malzemenin cikis yapilip yapilmadigini ogrenmemiz gerekiyor.

Malzemele cikislarinin oldugu klasor soyle: http://i.hizliresim.com/AJbdkQ.png

Totalde 1265 adet klasor var.

Her klasorun icinde ki form yapisi ayni, ornek: http://hizliresim.com/0DZoBV

Her klasorun icinde ayni sekilde 1 adet form var. Bu formlarin icinde Material Code kullanilarak arama yapilmasi gerekiyor.

Yardimlarinizi icin simdiden tesekkur ederim.
 
Son düzenleme:
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Daha detay bilgi için,

* Material Code dediğiniz, MC Number olarak mı geçiyor?
* Her form da satır sayısı iki midir? Daha fazla olabiliyor mu?
* Bir malzemenin çıkış yapılıp yapılmadığı mı? Kaç adet çıkış yapıldığı mı isteniyor?

* Örnek dosya ekleyiniz.
 
Son düzenleme:
S

sefayksl

Katılım
11 Haziran 2016
Mesajlar
25
Excel Vers. ve Dili
Office 2010
English
Altın Üyelik Bitiş Tarihi
26/02/2019
Hocam butun formlarda bulunan bir kelimeyi girdim bulunamadi hatasi veriyor.
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
sefayksl' Alıntı:
Hocam butun formlarda bulunan bir kelimeyi girdim bulunamadi hatasi veriyor.
Genişletmek için tıkla ...
Aranacak klasörü tüm dosyalarınızın bulunduğu ana klasör olarak belirttiniz mi?

Ekran görüntüsü gönderebilir mi siniz?

Ben denedim örnek dosyanızı buluyor.
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Dosyaların bulunduğu yol ile ilgili bir hat var.
Yazdığınız yolu kopyalayıp windows gezgini adres çubuğuna yapıştırıp, doprular mı sınız?

O:\Materials Control\Issue Note & Material Return Report\Issue Notes Sangachal (GREENFIELD)

Aşağıda bendeki arama sonuçları,

 
S

sefayksl

Katılım
11 Haziran 2016
Mesajlar
25
Excel Vers. ve Dili
Office 2010
English
Altın Üyelik Bitiş Tarihi
26/02/2019
Adres yolunuda degistirdim yine ayni hata hocam. Sanirim excell ile ilgili bir sikinti var.

Ilginiz icin tesekkur ederim
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
sefayksl' Alıntı:
Adres yolunuda degistirdim yine ayni hata hocam. Sanirim excell ile ilgili bir sikinti var.

Ilginiz icin tesekkur ederim
Genişletmek için tıkla ...
Hata verdiğinde, DEBUG deyin. Sarı alandaki değişkenlerin üzerine gelip, içeriğine bakar mısınız? Dosya yolu gibi değerler doğru mu?

DOsyaların bulunduğu konum zorunlu mu? Sadece bu klasör altında dener mi siniz?
O:\Materials Control
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Alternatif kod Açık olan dosyanızın A1:A sonuna kadar satır arasına verilerinizi yazın ve kodu çalıştırın.

Kod çalışınca veri alınacak klasörü seçin ve tamam deyin.

Kod: 
'Dim Kaynak As Object
Dim Sayfa_Adı As String
Dim dosya_adı As String

Sub deneme()


dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

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
'On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

uyarı = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " Temizleme Penceresi")
If uyarı = vbYes Then
Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False


Liste (Kaynak)
MsgBox "işlem tamam", vbInformation, "uyarı"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(Dosya)) = "xlsx" And Mid(Dosya.Name, 1, 2) <> "~$" Then
Dim KK As Worksheet
Dim BUL
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)

Set KK = Workbooks(Dosya.Name).Sheets(ActiveSheet.Name)

For i = 1 To ThisWorkbook.Sheets(Sayfa_Adı).[A65536].End(3).Row
Set BUL = KK.Range("A:A").Find(ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "A"), , xlValues, xlWhole)
If Not BUL Is Nothing Then

son = ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "B").End(3).Row + 1
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "b") = BUL.Value
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "c") = KK.Cells(BUL.Row, "b")
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "d") = KK.Cells(BUL.Row, "c")
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "e") = Dosya
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "f") = Dosya.Name
End If
Next i
wb.Close
End If

Next

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

Set fL = Nothing
End Sub
not: kod sadece uzantısı xlsx olan dosyalardan veri alır.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod da farklı Açık olan dosyanızın A2:A sonuna kadar satır arasına verilerinizi yazın ve kodu çalıştırın.

Kod çalışınca veri alınacak klasörü seçin ve tamam deyin.

Excel dosyalarının bütün sürümlerindeki verileri alır.

Kod: 
Dim Sayfa_Adı As String
Dim dosya_adı As String

Sub deneme()


dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

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
'On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

uyarı = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " Temizleme Penceresi")
If uyarı = vbYes Then
Range(Cells(2, 2), Cells(Rows.Count, Columns.Count)).ClearContents

ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "a") = "Aranan"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "b") = "Bulunan"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "c") = "Bulunan değirin yanındaki hücre"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "d") = "Bulunan satır"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "e") = "Dosya Adresi"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "f") = "Dosya adı"

End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False


Liste (Kaynak)
MsgBox "işlem tamam", vbInformation, "uyarı"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files


If fL.GetFileName(Dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(Dosya), 1, 2) = "~$" Then
GoSub atla1
End If

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

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then

Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then

Else
GoSub atla1
End If
End If

'If LCase(fL.GetExtensionName(Dosya)) = "xlsx" And Mid(Dosya.Name, 1, 2) <> "~$" Then
Dim KK As Worksheet
Dim BUL
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)

'Set KK = Workbooks(Dosya.Name).Sheets(ActiveSheet.Name)

Set KK = Workbooks(Dosya.Name).Sheets(Sheets(1).Name)

For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).[A65536].End(3).Row
Set BUL = KK.Range("A:A").Find(ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "A"), , xlValues, xlWhole)
If Not BUL Is Nothing Then
son = ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "B").End(3).Row + 1
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "b") = BUL.Value
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "c") = KK.Cells(BUL.Row, "b")
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "d") = BUL.Row
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "e") = Dosya
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "f") = Dosya.Name
End If
Next i
wb.Close
'End If
atla1:
Next

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

Set fL = Nothing
End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod da farklı Açık olan dosyanızın A2:A sonuna kadar satır arasına verilerinizi yazın ve kodu çalıştırın.

Kod çalışınca veri alınacak klasörü seçin ve tamam deyin.

Excel dosyalarının bütün sürümlerindeki BÜTÜN SAYFALARDAN verileri alır.

KOD:

Kod: 
Dim Sayfa_Adı As String
Dim dosya_adı As String

Sub deneme()


dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

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
'On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

uyarı = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " Temizleme Penceresi")
If uyarı = vbYes Then
Range(Cells(2, 2), Cells(Rows.Count, Columns.Count)).ClearContents

ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "a") = "Aranan"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "b") = "Bulunan"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "c") = "Bulunan değirin yanındaki hücre"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "d") = "Bulunan satır"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "e") = "Dosya Adresi"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "f") = "Dosya adı"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "g") = "Sayfa Adı"
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False


Liste (Kaynak)
MsgBox "işlem tamam", vbInformation, "uyarı"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files


If fL.GetFileName(Dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(Dosya), 1, 2) = "~$" Then
GoSub atla1
End If

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

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then

Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then

Else
GoSub atla1
End If
End If
'If LCase(fL.GetExtensionName(Dosya)) = "xlsx" And Mid(Dosya.Name, 1, 2) <> "~$" Then
Dim KK As Worksheet
Dim BUL
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)

'Set KK = Workbooks(Dosya.Name).Sheets(ActiveSheet.Name)
For r = 1 To Workbooks(Dosya.Name).Sheets.Count
Set KK = Workbooks(Dosya.Name).Sheets(Sheets(r).Name)
For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).[A65536].End(3).Row
Set BUL = KK.Range("A:A").Find(ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "A"), , xlValues, xlWhole)
If Not BUL Is Nothing Then
son = ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "B").End(3).Row + 1
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "b") = BUL.Value
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "c") = KK.Cells(BUL.Row, "b")
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "d") = BUL.Row
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "e") = Dosya
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "f") = Dosya.Name
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "g") = Sheets(r).Name
End If
Next i
Next r
wb.Close
'End If
atla1:
Next

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

Set fL = Nothing
End Sub
 
S

sefayksl

Katılım
11 Haziran 2016
Mesajlar
25
Excel Vers. ve Dili
Office 2010
English
Altın Üyelik Bitiş Tarihi
26/02/2019
K

KYenerSelvi

Katılım
28 Eylül 2018
Mesajlar
112
Excel Vers. ve Dili
Office Pro Plus 2016 Türkçe
Altın Üyelik Bitiş Tarihi
09-02-2023
halit3' Alıntı:
Bu kod da farklı Açık olan dosyanızın A2:A sonuna kadar satır arasına verilerinizi yazın ve kodu çalıştırın.

Kod çalışınca veri alınacak klasörü seçin ve tamam deyin.

Excel dosyalarının bütün sürümlerindeki BÜTÜN SAYFALARDAN verileri alır.

KOD:

Kod: 
Dim Sayfa_Adı As String
Dim dosya_adı As String

Sub deneme()


dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

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
'On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

uyarı = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " Temizleme Penceresi")
If uyarı = vbYes Then
Range(Cells(2, 2), Cells(Rows.Count, Columns.Count)).ClearContents

ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "a") = "Aranan"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "b") = "Bulunan"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "c") = "Bulunan değirin yanındaki hücre"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "d") = "Bulunan satır"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "e") = "Dosya Adresi"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "f") = "Dosya adı"
ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "g") = "Sayfa Adı"
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False


Liste (Kaynak)
MsgBox "işlem tamam", vbInformation, "uyarı"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
   
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files


If fL.GetFileName(Dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(Dosya), 1, 2) = "~$" Then
GoSub atla1
End If

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

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then

Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then

Else
GoSub atla1
End If
End If
'If LCase(fL.GetExtensionName(Dosya)) = "xlsx" And Mid(Dosya.Name, 1, 2) <> "~$" Then
Dim KK As Worksheet
Dim BUL
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)

'Set KK = Workbooks(Dosya.Name).Sheets(ActiveSheet.Name)
For r = 1 To Workbooks(Dosya.Name).Sheets.Count
Set KK = Workbooks(Dosya.Name).Sheets(Sheets(r).Name)
For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).[A65536].End(3).Row
Set BUL = KK.Range("A:A").Find(ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "A"), , xlValues, xlWhole)
If Not BUL Is Nothing Then
son = ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "B").End(3).Row + 1
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "b") = BUL.Value
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "c") = KK.Cells(BUL.Row, "b")
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "d") = BUL.Row
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "e") = Dosya
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "f") = Dosya.Name
ThisWorkbook.Sheets(Sayfa_Adı).Cells(son, "g") = Sheets(r).Name
End If
Next i
Next r
wb.Close
'End If
atla1:
Next

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

Set fL = Nothing
End Sub
Genişletmek için tıkla ...

Hocam eski bir konu fakat çok işe yarayacak bir uygulama.

-Aranmasını istediğimiz değeri A2 hücresine yazıyorum fakat makro çalışınca komple sayfayı yeniliyor. Aranan değeri nereye yazmamız lazım acaba ?
-Birde hocam arama yapmasını istediğimiz klasör yerine arka planda kod kısmına 15-20 tane excel dosyasının yolunu tanımlayabilme şansımız var mı. Aranacakları sadece o excellerde arasın performans açısından
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst