Alt klasörleri dahil etme

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
anlamadım ne demek istediğinizi
 

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
Rich (BB code):
For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A" & Rows.Count))

i = WorksheetFunction.CountA(ThisWorkbook.Worksheets(Sayfa_adi).Range("A1:A" & Rows.Count)) + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "b").Value = son
End If
Next r
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
halit3 hocam çok teşekkür ederim. Çok işime yarayacak bir kod oldu. Emeğinize sağlık. Bu haliyle de işime yaramakla birlikte Klasör\Klasör\Klasör içindeki excelleri görse iyi olur. Daha fazla vaktinizi almak istemem. İyi geceler.
 

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 klasörün içindeki bütün alt klasörlerin içindeki dosyaları görüyor

Klasör\Klasör\Klasör \Klasör\Klasör\Klasör \Klasör\Klasör\Klasör
bunu bile görür
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Evet hocam dediğiniz gibi alt klaösrlerin hepsini sayıyor. Elinize sağlık. Şöyle bir sorum olacak: 1 klsör (içinde 14 excel toplamda 310 sayfa) içindeki verileri 1 dk da sayıyor. Klasör sayısı 18 e çıktığında (klasörlerin içeriği aynı her bir klasörde 14 excel toplamda 310 sayfa var ) yaklaşık 1,5 saat sürüyor. Bu 18 sayfa için biraz uzun bir süre. Klasör sayısı arttıkça yavaşlıyor sanki.
 

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
Yani ortalama bir excell dosyasında 22 den fazla sayfa var bana kalırsa excell dosyalarının açılması uzun sürüyordur
bu kodu bir dene bu kod hiç veri almadan dosyaları açıp kapatıyor süre olarak bir değişiklik olacakmı

Kod:
Dim Sayfa_adi
Dim sat


Sub verikayityap2()
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
sat = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
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 Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

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

Set wb = Workbooks.Open(Dosya)
yenidosya_adı = ActiveWorkbook.Name
For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

End If
Next r

wb.Close
atla1:
Next

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

End Sub
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Hocam, aynı sayıdaki dosyayı 5 dakikada açtı ve kapadı. Veri alırken 90 dakikadan fazla bir zaman sürüyor .
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A" & Rows.Count))
A6:A yerine A6 dan A500 e kadar baksa yeterli olur, fakat 500 ile sınırlandırmayı başaramadım.
 

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
Birde bunu dene
Kod:
Dim Sayfa_adi
Dim sat

Sub verikayityap()
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
sat = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
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 Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

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

Set wb = Workbooks.Open(dosya)

yenidosya_adı = ActiveWorkbook.Name

For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A500))
sat = sat + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "b").Value = son
End If
Next r

wb.Close

atla1:
Next

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

End Sub
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Hocam süre olarak pek fark etmedi.
son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A" & Rows.Count))
A500 ile sınırlandırsak süre olarak fark eder mi sizce ?
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Birde bunu dene
Kod:
Dim Sayfa_adi
Dim sat

Sub verikayityap()
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
sat = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
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 Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

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

Set wb = Workbooks.Open(dosya)

yenidosya_adı = ActiveWorkbook.Name

For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A500))
sat = sat + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "b").Value = son
End If
Next r

wb.Close

atla1:
Next

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

End Sub
son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A500))

burada hata veri kodu ekleyince kırmızı oldu
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
30. mesajınızdaki kodu kullanmak istediğimde

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A500))

bu satır kırmızı oluyor.
 

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
Birde bu kodu dene

Kod:
Dim Sayfa_adi
Dim sat

Sub verikayityap()
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
sat = 1

Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
  
Liste (Kaynak)
  
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With


Set Klasor = Nothing
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 Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

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

Set wb = Workbooks.Open(dosya)

yenidosya_adı = ActiveWorkbook.Name

For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A" & Rows.Count))
sat = sat + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "b").Value = son
End If
Next r

wb.Close

atla1:
Next

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

End Sub
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Aşağıdaki kod ile aşağıdaki senaryoda 128 saniyede sonuç alabildim.

20 klasör
Klasörler içinde 30 excel dosyası
Her excel dosyasında 5 sayfa

Toplam veri sayısı 20 * 30 * 5 = 3.000

Kod:
Option Explicit

Dim Satir As Long

Sub Dosyalardan_Veri_Al()
    Dim Klasor As Object, Yol As String, Zaman As Double
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz!", 0)
    
    If Klasor Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için seçim yapmalısınız!", vbExclamation
        Exit Sub
    Else
        Yol = Klasor.Self.Path
    End If
        
    Zaman = Timer
        
    Application.ScreenUpdating = False
        
    Range("A2:B" & Rows.Count).Clear
    Satir = 2
    
    Call Alt_Klasorler(Yol, True)
    
    Application.ScreenUpdating = False
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Private Sub Alt_Klasorler(Yol As String, Tum_Alt_Klasorler As Boolean)
    Dim Dosya_Sistemi As Object, Alt_Klasor As Object, Dosya As Object
    Dim Sayfalar As Object, Sayfa As Worksheet, WF As WorksheetFunction
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Set Alt_Klasor = Dosya_Sistemi.GetFolder(Yol)
    Set WF = WorksheetFunction
    
    For Each Dosya In Alt_Klasor.Files
        If LCase(Dosya_Sistemi.GetExtensionName(Dosya.Name)) Like "*xls*" Then
            Set Sayfalar = GetObject(Dosya).Worksheets
            For Each Sayfa In Sayfalar
                Select Case Sayfa.Name
                    Case "açıklama"
                    Case Else
                        Cells(Satir, 1) = Sayfa.Name
                        Cells(Satir, 2) = WF.CountA(Sayfa.Range("A6:A" & Sayfa.Rows.Count))
                        Cells(Satir, 1).Resize(1, 2).Borders.LineStyle = 1
                        Satir = Satir + 1
                End Select
            Next
            Workbooks(Dosya.Name).Close 0
        End If
    Next
    
    If Tum_Alt_Klasorler = True Then
        For Each Alt_Klasor In Alt_Klasor.SubFolders
            Alt_Klasorler Alt_Klasor.Path, True
        Next
    End If

    Set Dosya_Sistemi = Nothing
    Set Alt_Klasor = Nothing
    Set WF = Nothing
End Sub
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Birde bu kodu dene

Kod:
Dim Sayfa_adi
Dim sat

Sub verikayityap()
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
sat = 1

Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
 
Liste (Kaynak)
 
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With


Set Klasor = Nothing
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 Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

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

Set wb = Workbooks.Open(dosya)

yenidosya_adı = ActiveWorkbook.Name

For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A" & Rows.Count))
sat = sat + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(sat, "b").Value = son
End If
Next r

wb.Close

atla1:
Next

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

End Sub
Hocam elinize sağlık. Çok uğraştınız. Gerçekten mükemmel oldu. 6 dk da tamamlandı 252 excel dosyasının sayımı.
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Merhaba,

Aşağıdaki kod ile aşağıdaki senaryoda 128 saniyede sonuç alabildim.

20 klasör
Klasörler içinde 30 excel dosyası
Her excel dosyasında 5 sayfa

Toplam veri sayısı 20 * 30 * 5 = 3.000

Kod:
Option Explicit

Dim Satir As Long

Sub Dosyalardan_Veri_Al()
    Dim Klasor As Object, Yol As String, Zaman As Double
   
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz!", 0)
   
    If Klasor Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için seçim yapmalısınız!", vbExclamation
        Exit Sub
    Else
        Yol = Klasor.Self.Path
    End If
       
    Zaman = Timer
       
    Application.ScreenUpdating = False
       
    Range("A2:B" & Rows.Count).Clear
    Satir = 2
   
    Call Alt_Klasorler(Yol, True)
   
    Application.ScreenUpdating = False
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Private Sub Alt_Klasorler(Yol As String, Tum_Alt_Klasorler As Boolean)
    Dim Dosya_Sistemi As Object, Alt_Klasor As Object, Dosya As Object
    Dim Sayfalar As Object, Sayfa As Worksheet, WF As WorksheetFunction
   
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Set Alt_Klasor = Dosya_Sistemi.GetFolder(Yol)
    Set WF = WorksheetFunction
   
    For Each Dosya In Alt_Klasor.Files
        If LCase(Dosya_Sistemi.GetExtensionName(Dosya.Name)) Like "*xls*" Then
            Set Sayfalar = GetObject(Dosya).Worksheets
            For Each Sayfa In Sayfalar
                Select Case Sayfa.Name
                    Case "açıklama"
                    Case Else
                        Cells(Satir, 1) = Sayfa.Name
                        Cells(Satir, 2) = WF.CountA(Sayfa.Range("A6:A" & Sayfa.Rows.Count))
                        Cells(Satir, 1).Resize(1, 2).Borders.LineStyle = 1
                        Satir = Satir + 1
                End Select
            Next
            Workbooks(Dosya.Name).Close 0
        End If
    Next
   
    If Tum_Alt_Klasorler = True Then
        For Each Alt_Klasor In Alt_Klasor.SubFolders
            Alt_Klasorler Alt_Klasor.Path, True
        Next
    End If

    Set Dosya_Sistemi = Nothing
    Set Alt_Klasor = Nothing
    Set WF = Nothing
End Sub
Korhan Hocam ilginize teşekkür ederim. Kodu şimdi çalıştırdım. Halit hocamın son yazdığı kod ile hemen hemen aynı sürede bitecek sanırım. Kod ile ilgili sonucu yazarım. Elinize sağlık.
 

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Korhan hocam 4000 civarı veriyi çok rahat bir şekilde saydı. (100 sn) Veri sayısı arttıkça sürede çok uzadı. Tahmini 12000 veri saymayı denemdim. excel yanıt vermiyor konumuna geçti. Benim veri aldığım excellerde formüller, makrolar var bu biraz zorluyor sanırım. İlginize teşşekür ederim.
 
Üst