Klasör Eçindeki Belirli Bir Dosyayı Aramak Ve Klasör İsmi ile Kopylama

med_cezir91 · 29 Temmuz 2019

Merhaba arkadaşlar. Alttaki formatta bir dosya dizinim var.

Kod:

sourcu
   file1
      fov
          image.jpg
  file2
     fov
         image.jpg
  file3
     fov
         image.jpg

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.

Kod:

destination
  file1.jpg
  file2.jpg
  file3.jpg

İnternette bir çok araştırma yaptım ama tam istediğim şeyi yapalabilecek bir formül bulamadım. Alttaki gibi bir kod buldum.

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

Ancak bu kodu dosya ismini de değiştirecek şekilde editleyemedim. Yardımcı olabilirseniz çok sevineceğim.

İyi günler dilerim.

med_cezir91 · 31 Temmuz 2019

Merhaba,

Günceldir, destek bekliyorum.

İyi günler dilerim.

halit3 · 31 Temmuz 2019

Alternatif kod
Bu kod JPG uzantılı dosyaları klasörleri ile kopyalama yapıyor.

Kod:

Dim Kaynak2 As String
Dim sat

Sub Dosyaları_kopyala()

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 Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

dosyalar2 = Split(Kaynak, "\")
For i = 0 To UBound(dosyalar2)
If CreateObject("Scripting.FileSystemObject").GetBaseName(Kaynak) = dosyalar2(i) Then
sat = i
End If
Next

Set Klasor2 = CreateObject("shell.application").browseforfolder(0, "Hedef sürücüyü seçin", 50, &H0)
If Not Klasor2 Is Nothing Then
Kaynak2 = Klasor2.SELF.Path
If InStr(1, Kaynak2, "{") > 0 Then GoTo Atla2
If Right(Kaynak2, 1) <> "\" Then Kaynak2 = Kaynak2 & "\"

Columns("A:A").ClearContents
Cells(1, 1).Value = "Değişenler"
Liste112 (Kaynak)

Set Klasor = Nothing
MsgBox "işlem tamam"

Else
Atla2:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste112(yol As String)
Dim fL As Object, f As Object, j As Long, Dosya As Object
Set fL = CreateObject("Scripting.FileSystemObject")

ekle = 0
yer1 = ""
dosyalar2 = Split(yol, "\")

For i = sat + ekle To UBound(dosyalar2)
If yer1 = "" Then
yer1 = dosyalar2(i)
Else
yer1 = yer1 & "\" & dosyalar2(i)
End If
If fL.FolderExists(Kaynak2 & yer1) = False Then
MkDir Kaynak2 & yer1
End If
Next


ekle1 = ""
If Right(yol, 1) <> "\" Then ekle1 = "\"
yol2 = Kaynak2 & yer1

For Each Dosya In fL.GetFolder(yol).Files
MsgBox Dosya
deg1 = yol & ekle1 & Dosya.Name
dosyalar = Split(yol, "\")
ekle = 0
yer3 = Trim(Mid(deg1, ekle + InStr(Trim(deg1), dosyalar(sat)), Len(deg1)))
aranan1 = Kaynak2 & yer3
aranan2 = deg1
uzanti = UCase(fL.GetExtensionName(aranan1))
MsgBox uzanti
If uzanti = "JPG" Then
fL.CopyFile aranan2, aranan1
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1).Value = aranan2
End If
Next


On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste112 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

med_cezir91 · 2 Ağustos 2019

Merhaba,

Üstte verdiğiniz kod ile direk kopyalama işlemi yapıyor. Benim işime yaraması için belirli bir isimdeki dosyaları 2 üst dizindeki klasörün adı ile ortak bir yere kopyalaması gerekiyor.

Bu işlemi yapması için yukardaki kod düzeltilebilir mi sizce ?

Kodların alt satırında

halit3 · 2 Ağustos 2019

Birde bunu dene

Kod:

Dim Kaynak3 As String

Sub Dosyaları_kopyala()

Set fL = CreateObject("Scripting.FileSystemObject")
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 Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

yer1 = fL.GetBaseName(fL.GetParentFolderName(fL.GetParentFolderName(Kaynak)))

Set Klasor2 = CreateObject("shell.application").browseforfolder(0, "Hedef sürücüyü seçin", 50, &H0)
If Not Klasor2 Is Nothing Then
Kaynak2 = Klasor2.SELF.Path
If InStr(1, Kaynak2, "{") > 0 Then GoTo Atla2
If Right(Kaynak2, 1) <> "\" Then Kaynak2 = Kaynak2 & "\"

Columns("A:B").ClearContents
Cells(1, 1).Value = "Eski Konum"
Cells(1, 2).Value = "Yeni Konum"
Kaynak3 = Kaynak2 & yer1

If fL.FolderExists(Kaynak3) = False Then
MkDir Kaynak3
End If

Liste112 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"

Else
Atla2:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste112(yol As String)
Dim fL As Object, f As Object, j As Long, Dosya As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files

aranan1 = Kaynak3 & "\" & Dosya.Name
aranan2 = Dosya
uzanti = UCase(fL.GetExtensionName(aranan1))

If uzanti = "JPG" Then
fL.CopyFile aranan2, aranan1
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1).Value = aranan2
Cells(j, 2).Value = aranan1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste112 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

med_cezir91 · 2 Ağustos 2019

Halit Hocam merhaba,

Dönüşünüz için teşekkürler ancak kod yine yanlızca kopyalama yaptı ve dosya isimlerini değiştirmedi, dosya isimleride aynı olduğu için her seferinde yeni dosyayı diğerinin üzerine yazıyor. Dosya ismini değiştirse (image.jpg >> file1.jpg gibi )aslında sorun kalmayacak.

İyi akşamlar dilerim.

halit3 · 2 Ağustos 2019

kod:

Kod:

Dim Kaynak3 As String

Sub Dosyaları_kopyala()

Set fL = CreateObject("Scripting.FileSystemObject")
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 Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

yer1 = fL.GetBaseName(fL.GetParentFolderName(fL.GetParentFolderName(Kaynak)))

Set Klasor2 = CreateObject("shell.application").browseforfolder(0, "Hedef sürücüyü seçin", 50, &H0)
If Not Klasor2 Is Nothing Then
Kaynak2 = Klasor2.SELF.Path
If InStr(1, Kaynak2, "{") > 0 Then GoTo Atla2
If Right(Kaynak2, 1) <> "\" Then Kaynak2 = Kaynak2 & "\"

Columns("A:B").ClearContents
Cells(1, 1).Value = "Eski Konum"
Cells(1, 2).Value = "Yeni Konum"
Kaynak3 = Kaynak2 & yer1

If fL.FolderExists(Kaynak3) = False Then
MkDir Kaynak3
End If

Liste112 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"

Else
Atla2:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste112(yol As String)
Dim fL As Object, f As Object, j As Long, Dosya As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files


aranan2 = Dosya
uzanti = UCase(fL.GetExtensionName(aranan2))

sat1 = fL.GetFolder(Kaynak3).Files.Count + 1
dosyaadi1 = "File1" & sat1
aranan1 = Kaynak3 & "\" & dosyaadi1

If uzanti = "JPG" Then

fL.CopyFile aranan2, aranan1 & "." & uzanti
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1).Value = aranan2
Cells(j, 2).Value = aranan1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste112 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

med_cezir91 · 3 Ağustos 2019

Hocam Merhaba dönüşünüz için tekrar teşekkürler,

Sayenizde önemli bir işimi halletmiş oldum önceki verdiğiniz kodlarda alttaki gibi değişiklik yapıp istediğim sonucu aldım.

Bash:

Dim Kaynak2 As String

Sub Dosyaları_kopyala()


'KAYNAK KLASÖRÜ  BURADA BELİRTTİM
Set fL = CreateObject("Scripting.FileSystemObject")
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 Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"


'HEDEF KLASÖRÜ BURADA BELİRTTIM
Set Klasor2 = CreateObject("shell.application").browseforfolder(0, "Hedef sürücüyü seçin", 50, &H0)
If Not Klasor2 Is Nothing Then
Kaynak2 = Klasor2.SELF.Path
If InStr(1, Kaynak2, "{") > 0 Then GoTo Atla2
If Right(Kaynak2, 1) <> "\" Then Kaynak2 = Kaynak2 & "\"

Columns("A:B").ClearContents
Cells(1, 1).Value = "Eski Konum"
Cells(1, 2).Value = "Yeni Konum"

Liste112 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"


Else
Atla2:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
Private Sub Liste112(yol As String)
Dim fL As Object, f As Object, j As Long, Dosya As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files

'KOPYALACAĞIM DOSYANIN İKİ ÜST DİZİN İSMİNİ BU KOD İLE ALDIM
yer1 = fL.GetBaseName(fL.GetParentFolderName(fL.GetParentFolderName(Dosya)))

aranan1 = Kaynak2 & "\" & Dosya.Name
dosyaisimyeni = Kaynak2 & "\" & yer1 & ".TXT"
aranan2 = Dosya
Filename = UCase(fL.GetFileName(aranan1))



If Filename = "BIGMAP.TXT" Then  'HANGİ İSİMLİ DOSYA İLE ÇALIŞMAK İSTİYOR İSEK
fL.CopyFile aranan2, dosyaisimyeni
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1).Value = aranan2
Cells(j, 2).Value = aranan1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste112 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Klasör Eçindeki Belirli Bir Dosyayı Aramak Ve Klasör İsmi ile Kopylama

med_cezir91

med_cezir91

halit3

Uzman

med_cezir91

halit3

Uzman

med_cezir91

halit3

Uzman

med_cezir91