Alt klasörleri dahil etme

[halit3]

anlamadım ne demek istediğinizi

 

[schlecht]

anlamadım ne demek istediğinizi

Hocam çözdüm sanırım. Her excelde açıklama diye bir sayfa var sorun o sayfa sanırım. Adı "açıklama" olsan sayfaları saymamasını nasıl sağlarım.

 

[halit3]

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]

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]

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]

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]

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ı

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]

Hocam, aynı sayıdaki dosyayı 5 dakikada açtı ve kapadı. Veri alırken 90 dakikadan fazla bir zaman sürüyor .

 

[schlecht]

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]

Birde bunu dene

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]

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]

Birde bunu dene

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

 

[halit3]

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

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

ne demek istediniz anlamadım

 

[schlecht]

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]

Birde bu kodu dene

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]

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

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]

Birde bu kodu dene

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]

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

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.

 

[Korhan Ayhan]

Test edebildiniz mi?

 

[schlecht]

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.