- Katılım
- 1 Mart 2011
- Mesajlar
- 7
- Excel Vers. ve Dili
- Microsoft Office Professional Excel 2010 (english)
Merhaba arkadaşlar. Alttaki formatta bir dosya dizinim var.
Benim yapmak istediğim şey source dizininin altındaki bütün alt dizinlerdeki image.jpg dosyalarını iki üst dizin ismi ile kopyalamak ve ortak bir yere yapıştırmak yani alttaki gibi.
İnternette bir çok araştırma yaptım ama tam istediğim şeyi yapalabilecek bir formül bulamadım. Alttaki gibi bir kod buldum.
Ancak bu kodu dosya ismini de değiştirecek şekilde editleyemedim. Yardımcı olabilirseniz çok sevineceğim.
İyi günler dilerim.
Kod:
sourcu
file1
fov
image.jpg
file2
fov
image.jpg
file3
fov
image.jpg
Kod:
destination
file1.jpg
file2.jpg
file3.jpg
Kod:
Sub tgr()
Dim sStartFolder As String
Dim sDestination As String
Dim sExtension As String
sStartFolder = "D:\program_deneme\source"
sDestination = "D:\program_deneme\destination\" '<-- The ending \ may be required on some systems
sExtension = "TXT"
SearchFoldersAndCopy sStartFolder, sDestination, sExtension
End Sub
Sub SearchFoldersAndCopy(ByVal arg_sFolderPath As String, _
ByVal arg_sDestinationFolder As String, _
ByVal arg_sExtension As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim sTest As String
'Test if FolderPath exists
sTest = Dir(arg_sFolderPath, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified folder [" & arg_sFolderPath & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'Test if Destination exists
sTest = Dir(arg_sDestinationFolder, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified destination [" & arg_sDestinationFolder & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'FolderPath and Destination both exist, proceed with search and copy
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(arg_sFolderPath)
'Test if any files with the Extension exist in directory and copy if one or more found
sTest = Dir(oFolder.Path & Application.PathSeparator & "*." & arg_sExtension)
If Len(sTest) > 0 Then oFSO.copyfile oFolder.Path & Application.PathSeparator & "*." & arg_sExtension, Destination:="D:\program_deneme\destination\"
'Recursively search subfolders
For Each oSubFolder In oFolder.SubFolders
SearchFoldersAndCopy oSubFolder.Path, arg_sDestinationFolder, arg_sExtension
Next oSubFolder
End Sub
İyi günler dilerim.