Klasör içindeki dosya ismi değiştirme

[igultekin2000]

İyi çalışmalar;
Vergi veya TC numarasına göre klasör olarak beyanname indiriyorum. Klasör isimlerini hazırladığım BAT dosyası ile pratik şekilde değiştirebiliyorum. Ancak klasör içindeki pdf dosyasının baş tarafındaki vergi/TC numarasına göre firmanın veya şahsın ismini yazdırmak istiyorum. Yaklaşık 150 civarındaki klasör içindeki dosyaların isimlerini toplu olarak nasıl değiştirebilirim. Makro olarak çözmek istiyorum. Teşekkür ederim.

 

[excelokyanus500]

Verilen kod vbs kodudur. Bir txt dosya açarak kodu yapıştırın ve vbs olarak kaydedin.
Denemeden önce klasörlerinizi yedekleyin. Öncesinde farklı bir klasörde deneyin.
Size değiştirmek istediğiniz dosya adı sorulacak ardından yeni adı istenecektir.
Buna göre doldurun.

Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = Browse4Folder
dim fname,fname2
fname=InputBox(TRSiz("Değiştirilmesini istediğiniz dosya TC"))
fname2=InputBox(TRSiz("Tercih ettiğiniz isim"))
Set objFolder = objFSO.GetFolder(objStartFolder)

Set colFiles = objFolder.Files
For Each objFile in colFiles
      tmpName = Replace(objFile, fname, fname2)
    
        objFSO.MoveFile objFile, tmpName
Next

ShowSubfolders objFSO.GetFolder(objStartFolder)
Sub ShowSubFolders(Folder)
    For Each Subfolder in Folder.SubFolders

        Set objFolder = objFSO.GetFolder(Subfolder.Path)
        Set colFiles = objFolder.Files
        For Each objFile in colFiles
        tmpName = Replace(objFile, fname, fname2)
    
        objFSO.MoveFile objFile, tmpName
        Next

        ShowSubFolders Subfolder
    Next
End Sub




Function TRSiz(vdata)
Dim tmp
tmp = Replace(vdata, "İ", "I")
tmp = Replace(tmp, "I", "i")
tmp = Replace(tmp, "ı", "i")
tmp = Replace(tmp, "Ğ", "G")
tmp = Replace(tmp, "ğ", "g")
tmp = Replace(tmp, "Ş", "S")
tmp = Replace(tmp, "ş", "s")
tmp = Replace(tmp, "Ç", "C")
tmp = Replace(tmp, "ç", "c")
tmp = Replace(tmp, "Ü", "U")
tmp = Replace(tmp, "ü", "u")
tmp = Replace(tmp, "ö", "o")
TRSiz = tmp
End Function


Function Browse4Folder()
    Dim objShell,objFolder,Message
    Message = TRSiz("Klasör seçin")
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0,Message,0,0)
    If objFolder Is Nothing Then
        Wscript.Quit
    End If
    Browse4Folder = objFolder.self.path
End Function

 

[igultekin2000]

Farklı çalışma; bu şekil makroyu ilk defa gördüm. Excel ile birlikte kullandığımız için txt dosyasında makro olduğunu öğrenmek beni şaşırttı. TC seçip, isim yazma seçeneği geliyor, sonrasında hata mesajı veriyor. Ancak çok fazla klasör var, ayda bir kaç çeşit grup halinde beyanname iniyor. Tek tek değiştirmem oldukça zaman alacak. Klasörlerin isimlerini içindeki PDF beyannamenin sadece başına eklemek gibi makro olsa da daha pratik olacak.

 

[halit3]

Aşağıdsaki linki irdeleyiniz.

Klasördeki Dosya İsimlerini Listeleme/Değiştirme

Bir klasörde bulunan dosya isimlerinin excel de A2 sütunundan başlayarak listelenmesini ve akabinde B2 sütunundaki isimlerle değiştirilmesini içeren 2 adet makroya ihtiyacım var (1-Listele, 2-Değiştir) Makroların bulunduğu klasörde çalışması yerine gözat ile gösterilen klasörde işlem yapması...

www.excel.web.tr

Klasör isim değiştirme,kopyalama,taşıma Makro Çalışması

Merhabalar, Ekli dosyada yapılması gerekenleri aşağıda detaylarını yazdığım gibi işlemleri yapa bilecek bir makro çalışmasına ihtiyacımız vardır. Buton ekleye bilinirse çok daha kolay olur bizler için.. Yardımlarınızı bekliyoruz. İSİMLER = Kaynak klasör yolunu gösterip o yolun içerisinde...

www.excel.web.tr

 

[igultekin2000]

Merhaba; konuyu epey inceledim ancak çözemedim. Koray bey tarafından eklenen listeleme ile klasör ve dosyaları listeliyorum. Dosyaların nasıl olması gerektiğini de karşılarına makro ile yazdırıyorum. Yeni isimler şeklinde eski dosya isimlerini değiştirmek istiyorum. Ancak bunu yapamadım. Bir örnek var ama adapte edemedim.

Private Sub CommandButton3_Click()

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

Range("A2:B65000").ClearContents
Range("D2:D65000").ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"
Liste11 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
deg = "Yeni Klasör"
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = yol & "\" & f.Name
Cells(j, 2) = f.Name
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[halit3]

Aşağıdaki linkdeki dosyayı irdeleyiniz (22 nolu mesajdaki)
1. temizle düğmesine tikla
2. Dosyaları bul düğmesine tikla
3. B Sutunundaki dosya isimleri sizin şu anki dosya isimleri C Sutununa değiştirmek istediğin dosyayı yaz
4. Dosyaların Adlarını Değiştir düğmesine tıkla

eğer değiştirdiğiniz isimler yanlış olursa (Dosyaların Adlarını Değiştir) dümesine tıkla

Klasördeki Dosya İsimlerini Listeleme/Değiştirme

Ofis 2003 için Denetim araç çubuğu yukarıdaki nesnelere mause ile sağ tıklayın ve denetim araç çubuğunu işaretleyiniz. denetim araç çubuğundan komut düğmesi ekleyeceksiniz.

www.excel.web.tr

 

[igultekin2000]

Teşekkür ederim, çok güzel çalışma. Büyük bir dertten kurtardınız. İyi çalışmalar.

 

[KARTAL133]

Merhaba @halit3 Hocam

isimlerin değişecek çalışma kitapların yerin sabitleyerek ilerliye bilirmiyiz.
o kadar arastırdım yapmaya çalıştımancak bulamadım.
yardımcı olmanızı rica ederim.

Örneğin aşağıdaki yol gibi tanımla yapa bilirmiyiz.
Doysya yol = "C:\Users\Deneme\"



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

 

[halit3]

Merhaba @halit3 Hocam

isimlerin değişecek çalışma kitapların yerin sabitleyerek ilerliye bilirmiyiz.
o kadar arastırdım yapmaya çalıştımancak bulamadım.
yardımcı olmanızı rica ederim.

Örneğin aşağıdaki yol gibi tanımla yapa bilirmiyiz.
Doysya yol = "C:\Users\Deneme\"



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

kod

Sub dosyaları_bul()
Worksheets(ActiveSheet.Name).Range("A2:D65000").ClearContents
Doysya_yol = "C:\Users\Deneme\"
Liste4 Doysya_yol
End Sub
Private Sub Liste4(yol As String)
Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya
Cells(j, 2) = fL.GetBaseName(Dosya.Name)
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste4 (f.Path)
sonraki:
Next

End Sub

 

[KARTAL133]

Hocam
emeğiniz için teşekkürler
hata veriyor

 

[KARTAL133]

tamam Hocam Hal ettim


aşağıdaki ekleme yaptım düzeldi.

Dim Dosya As String


Sub dosyaları_bul()
Dim Dosya As String

Worksheets(ActiveSheet.Name).Range("A265000").ClearContents
Dosya = "C:\Users\Murat\Downloads"
Liste Dosya
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya
Cells(j, 2) = fL.GetBaseName(Dosya.Name)
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub