Soru Ana klasördeki dosyaları listelemeden alt klasörleri listelemek

[seckinb]

Merhaba
Excel dosyalarının listesini çıkarmak için şöyle bir kod kullanıyorum.

Private Sub GetFilesInFolder(ByVal SourceFolderName As String, ByVal Subfolders As Boolean)
    
    If InStr(SourceFolderName, "000_Sablon") Then Exit Sub
    
    If InStr(SourceFolderName, "Eski") Then Exit Sub
    
    If InStr(SourceFolderName, ActiveWorkbook.Path) Then Exit Sub
        
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = fs.GetFolder(SourceFolderName)
    Set s1 = ThisWorkbook.Worksheets("hiper")

    r = s1.Range("A" & s1.Rows.Count).End(xlUp).Row + 1
    For Each FileItem In SourceFolder.Files
     If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" Then
        s1.Cells(r, 1).Formula = FileItem.Path
        r = r + 1
     End If
    Next FileItem

    If Subfolders = True Then
        For Each SubFolder In SourceFolder.Subfolders
            GetFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fs = Nothing
End Sub

Eski ve 000_sablon klasörlerini listeye eklememeyi başardım.
Ancak alt klasörleri listeler iken (0XXX, 1XXX gibi), ana klasördeki dosyaları listeye dahil etmesin istiyorum.

" If InStr(SourceFolderName, ActiveWorkbook.Path) Then Exit Sub "

nasıl yapabilirim?

ActiveWorkbook.Path yazınca kod doğrudan çalışmayı sonlandırıyor.

Teşekkürler.

 

[Muzaffer Ali]

Aşağıdaki satırı silin.

If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" Then

Yerine aşağıdaki satırı kopyalayın.

If Not FileItem.Name Like "~*" And Not FileItem.path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" And Not ThisWorkbook.path = Left(FileItem.path, InStrRev(FileItem.path, Application.PathSeparator)) Then

 

[seckinb]

Aşağıdaki satırı silin.

If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" Then

Yerine aşağıdaki satırı kopyalayın.

If Not FileItem.Name Like "~*" And Not FileItem.path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" And Not ThisWorkbook.path = Left(FileItem.path, InStrRev(FileItem.path, Application.PathSeparator)) Then

Malesef halen "ThisWorkbook.path" üzerindeki xslm dosyalarını listeliyor.

Private Sub GetFilesInFolder(ByVal SourceFolderName As String, ByVal Subfolders As Boolean)
    
    If InStr(SourceFolderName, "000_Sablon") Then Exit Sub
    
    If InStr(SourceFolderName, "Eski") Then Exit Sub
            
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = fs.GetFolder(SourceFolderName)
    Set s1 = ThisWorkbook.Worksheets("hiper")

    r = s1.Range("A" & s1.Rows.Count).End(xlUp).Row + 1
    For Each FileItem In SourceFolder.Files
     If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" And Not ThisWorkbook.Path = Left(FileItem.Path, InStrRev(FileItem.Path, Application.PathSeparator)) Then
        s1.Cells(r, 1).Formula = FileItem.Path
        r = r + 1
     End If
    Next FileItem

    If Subfolders = True Then
        For Each SubFolder In SourceFolder.Subfolders
            GetFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fs = Nothing
End Sub

 

[Muzaffer Ali]

O satır yerine aşağıdakini deneyin.

If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" And Not ThisWorkbook.Path = FileItem.Path Then

Yine de olmazsa o satırın altına aşağıdaki satırı ekleyin, kodu çalıştırın..

msgbox ThisWorkbook.Path & vblf & FileItem.Path

Mesajın ekran görüntüsünü paylaşın.

 

[seckinb]

O satır yerine aşağıdakini deneyin.

If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" And Not ThisWorkbook.Path = FileItem.Path Then

Yine de olmazsa o satırın altına aşağıdaki satırı ekleyin, kodu çalıştırın..

msgbox ThisWorkbook.Path & vblf & FileItem.Path

Mesajın ekran görüntüsünü paylaşın.

Malesef çalışmadı.

 

[halit3]

Bu kodu bir dene

Sub deneme()
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 Len(Kaynak) <= 3 Then
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
End If

Liste (Kaynak)
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, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).Subfolders

Liste (f.Path)

Set s1 = ThisWorkbook.Worksheets("hiper")

r = s1.Range("A" & s1.Rows.Count).End(xlUp).Row + 1
For Each FileItem In f.Files
If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" Then
s1.Cells(r, 1).Formula = FileItem.Path
r = r + 1
End If
Next FileItem


sonraki:
Next

Set fL = Nothing

End Sub

 

[seckinb]

Kullandığım kodun tamamını paylaşsam sanırım daha iyi olacak

Sub hiper1()
On Error Resume Next

ThisWorkbook.Worksheets("hiper").Select

fld = GetFolder()
If fld = "" Then Exit Sub

Set s1 = ThisWorkbook.Worksheets("hiper")
s1.AutoFilterMode = False
s1.Cells.delete
s1.Range("A1:Z1") = Array("Dosya", "No", "Ad", "Soyad", "TC no", "Doğum Tarihi", "Tanısı", "PATOLOJİ", "Telefon1", "Telefon2", "DOKTORU", "kür sayısı", "1.kür dozu", "toplam doz", "ilk doz t", "son doz t", "versiyon", "oyku", "oyku1", "oyku2", "oyku3", "pet", "pet1")
s1.Range("1:1").Font.Bold = True

Call GetFilesInFolder(fld, True) 'önce alt klasordeki dosyaların tam bir listesini yap..
s1.Columns.AutoFit

Call islemiptal

'son tek tek bu dosyaları kontrol et..
Application.DisplayAlerts = False
For i = 2 To s1.Rows.Count
    If s1.Cells(i, 1) = "" Then Exit For
        Application.ScreenUpdating = False
        Set w = Application.workbooks.Open(s1.Cells(i, 1))
        For Each sh In w.Worksheets
            If LCase(sh.Name) Like "k?ml?k" Then
                s1.Cells(i, 2) = sh.Range("J4").Value
                
            End If
        Next
        
        w.Saved = True
        w.Close
        Application.ScreenUpdating = True
        DoEvents
        s1.Columns.AutoFit
        
        
s1.Cells(Rows.Count, 2).End(xlUp).Row.Select

        
Next

s1.Range("K1").AutoFilter
s1.Range("A1:AA2000").WrapText = False


Call formatduplicates
Call addHypers
Call islemnormal

End Sub

Private Function GetFolder() As String

    GetFolder = ActiveWorkbook.Path
End Function


Private Sub GetFilesInFolder(ByVal SourceFolderName As String, ByVal Subfolders As Boolean)
    
    If InStr(SourceFolderName, "000_Sablon") Then Exit Sub
    
    If InStr(SourceFolderName, "Eski") Then Exit Sub
            
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = fs.GetFolder(SourceFolderName)
    Set s1 = ThisWorkbook.Worksheets("hiper")

    r = s1.Range("A" & s1.Rows.Count).End(xlUp).Row + 1
    For Each FileItem In SourceFolder.Files
     If Not FileItem.Name Like "~*" And Not FileItem.Path = ThisWorkbook.FullName And FileItem.Name Like "*.xlsm" And Not ThisWorkbook.Path = Left(FileItem.Path, InStrRev(FileItem.Path, Application.PathSeparator)) Then
        s1.Cells(r, 1).Formula = FileItem.Path
        r = r + 1
     End If
    Next FileItem

    If Subfolders = True Then
        For Each SubFolder In SourceFolder.Subfolders
            GetFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fs = Nothing
End Sub