Değişken Alt Klasörlerden Döküman Arama ve Kopyalama

[Said ERSOY]

Merhaba Herkese,

Excel VBA kullanarak ağ da bulunan klasörden masa üstümde yer alan bir klasör içerisine pdf dökümanları kopyalamak istiyorum. İnternette çok yerde araştırdım bir klasör içerisindeki dökümanı kopyalamada sorun yaşamıyorum fakat değişik isimlerde alt klasörler içerisinde dökümanı aratıp kopylama işlemi yaptıramıyorum. Yardımcı olabilir misiniz.

Kurgum: Excelde A sütunununa yazdığım dosya adlarının ilk 8 hanesini kontrol ederek ağdaki SATIN ALMA\klasör1\Test , SATIN ALMA\klasör2\Test, SATIN ALMA\klasör3\Test gibi klasörler içerisinde pdf dökümanını bulup hedef klasöre kopya oluşturmak.

aranacak döküman isimlerinin formatı AY-1000-xxxx, AY-1001-xxxx, AY-1002-xxxx gibi isimlerdir. xxxx kısmı genelde sabit oluyor.

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




Sub Kopyala()

Dim FSO
Dim dokuman As String
Dim kaynak As String
Dim hedef As String
Dim i As Integer
Dim k As Integer

k = Selection.Cells.Count


'Kaynak klasör
kaynak = "\\Ağ klasörü\planlama\SATIN ALMA\xxxxx(değişken alt klasör ismi)\Test\"

'Hedef klasör
hedef = "C:\Users\Desktop\Mail At\"

'Create Object for File System
Set FSO = CreateObject("Scripting.FileSystemObject")

Range("A2").Select

For i = 0 To k - 1
dokuman = Selection & ".pdf"

'Kaynak klsörde dosya mevcut mu diye bakılıyor.
If Not FSO.FileExists(kaynak & dokuman) Then
MsgBox "Specified File Not Found in Source Folder", vbInformation, "Not Found"

'Dosya zaten hedef klasörde yok ise, dosya kopyalanır
ElseIf Not FSO.FileExists(hedef & dokuman) Then
FSO.CopyFile (kaynak & dokuman), hedef ', True
Else
MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If
Selection.Offset(1, 0).Select
Next

End Sub

 

[Said ERSOY]

Konuyu yanlış yere mi açtım. üstadlar yardımcı olur musunuz?

 

[excelokyanus500]

Alıntı ..
buradan
Deneyin

Public Sub CopyFiles_r2()

    Dim sPathSource As String, sPathDest As String, sFileSpec As String

    sPathSource = "C:\Users\Me\SourceFolder\"  '  Aranan klasör
    sPathDest = "Z:\DestinationFolderTree\SubFolder\EndpointFolder\"  ' Hedef

    'sFileSpec = "*.xlsx"
    'sFileSpec = "*example*2020.xl*"
    sFileSpec = "*.pdf"

    Call CopyFiles_FromFolderAndSubFolders(sFileSpec, sPathSource, sPathDest)
End Sub


Public Sub CopyFiles_FromFolderAndSubFolders(ByVal argFileSpec As String, ByVal argSourcePath As String, ByRef argDestinationPath As String)

    Dim sPathSource As String, sPathDest As String, sFileSpec As String

    Dim FSO         As Object
    Dim oRoot       As Object
    Dim oFile       As Object
    Dim oFolder     As Object

    sPathSource = argSourcePath
    sPathDest = argDestinationPath

    If Not Right(sPathDest, 1) = "\" Then sPathDest = sPathDest & "\"
    If Right(sPathSource, 1) = "\" Then sPathSource = Left(sPathSource, Len(sPathSource) - 1)

    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FolderExists(sPathSource) And FSO.FolderExists(sPathDest) Then
        Set oRoot = FSO.GetFolder(sPathSource)
        For Each oFile In oRoot.Files
            If LCase(oFile.Name) Like argFileSpec Then
                On Error Resume Next
                oFile.Copy sPathDest & oFile.Name
                On Error GoTo 0
            End If
        Next oFile
        For Each oFolder In oRoot.SubFolders
            ' == do the same for any folder ==
            Call CopyFiles_FromFolderAndSubFolders(argFileSpec, oFolder.Path, sPathDest)
        Next oFolder
    End If
End Sub