Klasörden koşullu dosya ismi kopyalama ?

[Gorarr]

Selamlar, VBA kodu ile yapmak istediğim, bir klasör içindeki dosyaların isimlerini herhangi bir rakam başlayana kadar ki kısmının bir sütuna kopyalanması. yardımcı olabilirseniz çok sevinirim.

Örn.: D:\Filmler\the.battleground.2012.mkv
D:\Filmler\the.matrix.1080p.mkv
D:\Filmler\a.bus's.live720p.2002.avi

Bunların A sütununa : the.battleground.
the.matrix.
a.bug's.live


bu şekilde topluca kopyalamam gerekiyor. (noktalar önemli değil) yardımlarınız için şimdiden çok teşekkür ederim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Kırmızı ile belirttiğim yolu kendinize uyarlayınız.

Yol = "C:\Filmler\"

Sub DosyaListele()
    
    Dim Yol     As String, _
        Dosya   As String, _
        Dsy     As String, _
        i       As Long, _
        j       As Integer
        
        
    Application.ScreenUpdating = False
    Yol = "C:\Filmler\"
    
    Dosya = Dir(Yol & "*.*")
    Range("A:A").ClearContents
    i = Cells(Rows.Count, "A").End(3).Row
    
    While Dosya <> ""
        i = i + 1
        j = 1
        For j = 1 To Len(Dosya)
            If IsNumeric(Mid(Dosya, j, 2)) = True Then Exit For
        Next j
        If Mid(Dosya, j - 1, 1) = "." Then j = j - 1
        Cells(i, "A") = Left(Dosya, j - 1)
        Dosya = Dir
    Wend
    
    Application.ScreenUpdating = True
    MsgBox i - 1 & " ADET DOSYA LİSTELENMİŞTİR...", vbInformation, "N. YEŞERTENER"
    
End Sub

 

[Gorarr]

Necdet hocam ellerinize sağlık çok teşekkür ederim. İstediğim gibi olmuş birde kullanınca farkettim, eğer zahmet olmazsa 2 özellik daha eklemek mümkünmü.

1- alt klasörleri hesaba katmamışım, onu görmesini sağlayabilirmiyiz
2- birde başlangıçda klasör seçme özelliği olabilirmi.

Teşekkür ederim. Hayırlı bayramlar..

 

[Necdet]

Merhaba,

Kodların büyük kısmı http://excelexperts.com/VBA-Tips-List-Files-In-A-Folder sitesinden alınmıştır.

Referanslardan Microsoft Scripting Runtime seçili olmalı

Dim iRow
Dim iCol

'Kodların alındığı site
'http://excelexperts.com/VBA-Tips-List-Files-In-A-Folder

'Referanslardan Microsoft Scripting Runtime Seçili olmalı
Sub ListFiles()
    
    Dim Yol As String
    
    Application.ScreenUpdating = True
    Yol = KlasorSec
    If Yol = "" Then Exit Sub
    
    Yol = Yol & Application.PathSeparator
    iRow = Cells(Rows.Count, "A").End(3).Row
    If iRow < 2 Then iRow = 2
    Range("A2:A" & iRow).ClearContents
    
    iRow = 2
    
    Call ListMyFiles(Yol, "True")
    Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = False
    
End Sub

Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    Dim MyObject
    Dim mySource
    Dim myFile
    Dim mySubFolder
    Dim j As Integer
    
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    On Error Resume Next
    
    For Each myFile In mySource.Files
        
        For j = 1 To Len(myFile.Name)
            If IsNumeric(Mid(myFile.Name, j, 2)) = True Then Exit For
        Next j
        If Mid(myFile.Name, j - 1, 1) = "." Then j = j - 1
        Cells(iRow, "A") = Left(myFile.Name, j - 1)
        
        Cells(iRow, "B").Value = myFile.Size
        iRow = iRow + 1
    Next
    
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            Call ListMyFiles(mySubFolder.Path, True)
        Next
    End If
    
End Sub

Function KlasorSec() As String
    Dim ObjFolder   As Variant
 
    Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
 
    If Not ObjFolder Is Nothing Then
        KlasorSec = ObjFolder.Items.Item.Path
    Else
        KlasorSec = ""
    End If
End Function

 

[Gorarr]

Hocam çok sağolun ellerinize sağlık.....

 

[Necdet]

Hocam çok sağolun ellerinize sağlık.....

Güle güle kullanınız.

 

[Gorarr]

Hocam tekrar selamlar, #2 numaralı mesajınızdaki kodlarda şöyle bir sadeleştirme yapılabilirmi.

= Herhangi bir klasörden alma işlemi olmadan direkt A sütununda önceden yazılmış olan isimleri aynı şekilde "rakam" gelinceye kadarki kısmı alıp, B sütununa kopyalamasını sağlayabilirmiyiz.

Yardımınız için şimdiden teşekkürler.