Soru Klasördeki seçilen dosyaları kopyala farklı kaydet

[ikikan]

Arkadaşlar bu kod ile bir dosyayı istediğim yere kopyalıya biliyorum istediğim
farklı bir ad vererek kopyalamak bu bümkünmü.

Sub Kopyalama()
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Dosya Seçiniz"
If .Show = True Then
dosya = .SelectedItems(1)
End If
End With
fso.CopyFile dosya, ThisWorkbook.Path & "\Resim Dosyaları\"
End Sub

 

[Korhan Ayhan]

Bu satırı;

fso.CopyFile dosya, ThisWorkbook.Path & "\Resim Dosyaları\"

Aşağıdaki gibi değiştirip deneyiniz.

fso.CopyFile dosya, ThisWorkbook.Path & "\Resim Dosyaları\Deneme." & VBA.CreateObject("Scripting.FileSystemObject").GetExtensionName(dosya)

 

[ikikan]

Teşekkürler Dediğiniz gibi oldu.
Ve ayrıca tüm dosya uzantılarında çalışıyor.
Dosya sonuna tarihi de yazdırdım.

Tek eksik olan birden fazla dosya seçmemesi
Soru: Şunu yapabilirmiyiz 10 tane pdf veya jpg dosyası seçtik bunu inputbox kutusuna yazdığımızda
Örnek dosya ismi mutlu olsun mutlu1 mutlu2 mutlu3 ... seçilen dosya kadar kayıt yapabilirmiyiz?

Sub Kopyalama()
Dim fso As Object
Dim D_Adı As String
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Dosya Seçiniz"
If .Show = True Then
dosya = .SelectedItems(1)
End If
End With
D_Adı = Application.InputBox("Dosya ismi", "Sordum Gitti Valla", Type:=2) & "-" & Date

fso.CopyFile dosya, ThisWorkbook.Path & "\Resim Dosyaları\" & D_Adı & "." & _
VBA.CreateObject("Scripting.FileSystemObject").GetExtensionName(dosya)
End Sub

 

[ikikan]

Ayrıca bu seçilen dosyaları açmadan yazdıra bilir miyiz?

 

[Korhan Ayhan]

Deneyiniz.

Çoklu dosya seçip işlem yapabilirsiniz. (Umarım doğru anlamışımdır...)

Option Explicit

Sub Dosya_Kopyala()
    Dim Dosya_Sistemi As Object, Dosya_Secimi As FileDialog
    Dim Yol As String, Dosya As Variant, Dosya_Adi As Variant
   
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Set Dosya_Secimi = Application.FileDialog(msoFileDialogFilePicker)
   
    With Dosya_Secimi
        .AllowMultiSelect = True
        .Title = "Lütfen dosya seçiniz..."

        If .Show = True Then
            Yol = ThisWorkbook.Path & Application.PathSeparator & _
                  "Resim Dosyaları" & Application.PathSeparator
           
            If Dir(Yol, vbDirectory) = "" Then MkDir Yol
                 
            Dosya_Adi = InputBox("Lütfen dosya adını giriniz...", "Dosya Adı")
           
            If Dosya_Adi = "" Or Dosya_Adi = False Then
                MsgBox "Dosya adı girmediğiniz için işlem iptal edilmiştir!", vbCritical
                Exit Sub
            End If
                 
            Dosya_Adi = Dosya_Adi & " " & Format(Date, "dd_mm_yyyy")
                 
            For Each Dosya In .SelectedItems
                Say = Say + 1
                CreateObject("Scripting.FileSystemObject").Copyfile Dosya, Yol & Dosya_Adi & " " & Say & "." & _
                CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)
            Next
           
            MsgBox "İşleminiz tamamlanmıştır.", vbInformation
        Else
            MsgBox "Dosya seçimi yapmadığınız için işlem yapılamamıştır!", vbExclamation
        End If
    End With
   
    Set Dosya_Sistemi = Nothing
    Set Dosya_Secimi = Nothing
End Sub

 

[ikikan]

Çok Teşekkürler bana kalsa 1 ayda mantığını bile oturtamazdım elinize yüreğinize sağlık tam istediğim gibi olmuş.