Çözüldü Alt Klasörler İçerisindeki Excel Dosyalarının Şarta Bağlı Olarak Adlarını Değiştirmek Ve Belirtilen Klasör İçerisine Kopyalamak

[ErdalÖzdemir]

Merhaba arkadaşlar.

Yapmak istediğim işlem;
1-Alt klasör içerisindeki dosya adı “*Deneme Sonuçları*” olan Excel dosyalarının adının başına dosya yolundaki okul adını getirmek.
Önek: PAZARICI LİSESİ/ Deneme Sonuçları

2- Adı değişen bu Excel dosyalarını bildirtilen klasöre kopyalamak

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

-----------------------------------------------------------------------
Üzerinde dosya kopyalama için çalıştığım kod;
Bu kodda Klasör içerindeki tüm dosyaları kopyalıyor.

Sub DOSYA_KOPYALA_ALT_KLASOR()

Dim FileSystem As Object
Dim ws As Worksheet

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject

Dim Kaynak As String
Dim Hedef As String

Kaynak = "C:\Users\Serhat\Desktop\DENEME\DEĞERLENDİRME"
Hedef = "C:\Users\Serhat\Desktop\DENEME\Yeni klasör"

DoFolder fso.GetFolder(Kaynak)

'fso.CopyFile Kaynak, Hedef
fso.CopyFolder Kaynak, Hedef


With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

MsgBox "Arama Tamamlandi"

End Sub
Private Sub DoFolder(Folder)

Dim SubFolder
Dim File

For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next SubFolder

For Each File In Folder.Files
If LCase(fso.GetFileName(File.Name) Like "*Deneme Sonuçları*") Then 'DOSYASININ ADINA GÖRE DOSYA SEÇİMİ YAPSIN
' 'CheckFile File.Path
End If
Next File

End Sub

 

[ÖmerFaruk]

Arama menüsünü tavsiye ederim.
Sonuçlardan birisi
https://www.excel.web.tr/threads/makro-ile-dosya-adi-degistirme.146435/

 

[ErdalÖzdemir]

Ömer Bey teşekkür ederim.
İnceledim fakat benim işlem biraz faklı/ ben uyarlayamadım
Binim işlemimde FileDialog kullanmadan dosya adına göre işlem yapılacak.

 

[ÖmerFaruk]

1. Mevcutta dosya adlarınızın yapısı nasıldır?
2. Mevcutta Dosya yolu nasıldır? Okul adı neresindedir?

3. Adı değişmiş dosyaları belirtilen klasöre taşırken klasör nerededir? İsmi nedir?

 

[ErdalÖzdemir]

Ömer Bey Merhaba

Dosya Yolu Örnek= C:\Users\ErdalOZDEMIR\Desktop\DENEME\DEĞERLENDİRME\DANİŞMENT\ÖZEL KARTOPU ANADOLU LİSESİ\Deneme Sonuçları (11).xls\xlsx

Burada Dosya adının başına okul adı gelecek. Önek: ÖZEL KARTOPU ANADOLU LİSESİ / Deneme Sonuçları

Kaynak = C:\Users\ErdalOZDEMIR\Desktop\DENEME\DEĞERLENDİRME
Hedef=C:\Users\ErdalOZDEMIR\Desktop\DENEME\Yeni klasör


Örnek dosya

Yeni WinRAR ZIP arşivi.zip

İçerik Yönetim Sistemi, İstediğinizi Paylaşın, Dosyalarınız Güvende, Veri Şifreleme, Güçlü Arama

bulut.meb.gov.tr

 

[ÖmerFaruk]

Şu mudur?
Değerlendirme klasörünün altındaki
tüm alt klasörler dahil
her bir dosyanın isminin başına
bulunduğu klasör adını ekle
Ve Değerlendirme Klasörüyle aynı konumda bulunan YENİ KLASÖR altına dosya olarak kaydet.

 

[ErdalÖzdemir]

Evet Ömer Hocam aynen dediğiniz gibi

 

[ErdalÖzdemir]

Ömer Hocam, dosya adında “*Deneme Sonuçları*” geçen dosyaların adı değişecek ve Yeni klasör içerisine kopyalanacak.

 

[ÖmerFaruk]

Aşağıdaki kodları kullanabilirsin.
Kodlar forumda ARA menüsünden bulunmuş olup, @Haluk beyin kodlarıdır. Ben sadece ufak bir revizyon yaptım.
Siz üstteki kodu çalıştıracaksınız. Ben kendi bilgisayarımda denedim, sorun görmedim.

Sub DosyalarıYeniAdlaKopyala()
'   Haluk
'   15/10/2018
    Dim myFolder As String
    myFolder = "D:\Exceller\Excel Arşivleri" 'Buraya kendi kaynak klasörünüzü yazın
    Call GetFiles(myFolder, True)
End Sub
'
Sub GetFiles(SourceFolder As String, IncludeSubFolders As Boolean)
    Dim FSO As Object, strFolder As Object
    Dim SubFolder As Object, strFile As Object
    Dim myTargetPath As String
    
    myTargetPath = "D:\Exceller\xxx\" 'Buraya kendi hedef klasörünüzü yazın
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set strFolder = FSO.GetFolder(SourceFolder)

    On Error Resume Next
    For Each strFile In strFolder.Files
        If InStr(1, FSO.GetBaseName(strFile.Name), "Deneme Sonuçları") > 0 Then
            'Dosya adını direkt aldım. Dosya adının içindeki () içindeki diğer ifadeleri süzmeden kullandım.
            myNewFolder = myTargetPath & Replace(FSO.GetFileName(strFile), FSO.GetBaseName(strFile.Name), strFolder.Name & "_" & FSO.GetBaseName(strFile.Name))
            FileCopy FSO.GetAbsolutePathName(strFile), myNewFolder
        End If
    Next
    If IncludeSubFolders = True Then
        For Each strFolder In strFolder.SubFolders
            GetFiles strFolder.Path, True
        Next
    End If
    On Error GoTo 0
    Set strFolder = Nothing
    Set FSO = Nothing
End Sub

 

[ErdalÖzdemir]

Ömer Bey,
Size de Haluk Beye de çok teşekkür ederim.
Elinize emeğinize sağlık.