Klasörlerden dosya taşımak

[igultekin2000]

Merhaba; Formda bulduğum dosyaları listeleme ile klasörlerin içindeki dosyaları listeliyorum. Listede sonda TAH.pdf yazan dosyaları masaüstünde ki TAHAKKUK klasörüne toplu olarak aktarmak istiyorum. Site aradım ancak bulamadım. Teşekkür ederim.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin. Forum içinde movefile kelimesi ile de arama yapabilirsiniz.

Set nesne = CreateObject("Scripting.FileSystemObject")

For a = 3 To Cells(Rows.Count, "B").End(3).Row

If InStr(Cells(a, "B"), "TAH") > 0 Then
nesne.MoveFile Cells(a, "A") & Cells(a, "B"), "C:\Users\XXXX\Desktop\TAHAKKUK\" & Cells(a, "B")
End If

Next

 

[igultekin2000]

Merhaba; Yazdığınız makroyu adapte edemedim. Ancak forum sitesinde çalışabileceğim makro buldum. Gerçi sade tahakkukları taşımıyor ama bu şekilde de kullanabilir. Gerçi dosyalar Beyanname klasörünün içindeki klasöre taşınıyor. Masaüstüne klasör açıp oraya taşısa daha kullanışlı olurdu. Form sitesi çok faydalı oluyor. Emeği geçenlere teşekkür ederim.

Sub Dosya_Listele()
Set ds = CreateObject("Scripting.FileSystemObject")
anayol = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\Beyanname"
yol = anayol
Columns(1).Clear
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        If kls <> anayol & "\topla" Then klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
dosya = Dir$(yol & "\*.*")
Do While dosya <> ""
Say = Say + 1
ds.CopyFile yol & "\" & dosya, anayol & "\topla\" & dosya
dosya = Dir$()
Loop
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x
End Sub