makro ile dosya adı değiştirme

E

excelrua

Katılım
20 Mayıs 2014
Mesajlar
8
Excel Vers. ve Dili
2010
arkadaşlar elimde dosyalistesi adlı bir excel dosyası var ve bunun A sutununda

D:\dosyalar klasöründekidosya isimleri b sutununda ise olması gereken dosya isimleri var

bunu çalıştırıp uzantıları değiştirmeden sadece adları değiştircek bir makroya ihtiyacım var

Şimdiden teşekkurler
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
excelrua' Alıntı:
arkadaşlar elimde dosyalistesi adlı bir excel dosyası var ve bunun A sutununda

D:\dosyalar klasöründekidosya isimleri b sutununda ise olması gereken dosya isimleri var

bunu çalıştırıp uzantıları değiştirmeden sadece adları değiştircek bir makroya ihtiyacım var

Şimdiden teşekkurler
Genişletmek için tıkla ...
kodları sayfanın kod bölümüne koyun ve üç adet sayfaya komut düğmesi ekleyin (CommandButton1_Click) komut düğmesine tıklayın ve dosyaların adını değiştireceğiniz klasörü seçin ve tamamı tıklayın ilgili dosya isimleri A ve B sutünunda sıralanacaktır siz C sütünuna değişecek dosya adını yazınız ve (CommandButton2_Click) düğmesini tıklayınız. eğer işlemi geri almak istiyorsanız (CommandButton3_Click) düğmesini tıklayınız.

ayrıca diğer bir sayfada kod dosya uzantılarınıda değiştiriyor.

görsel resimleri de ekliyorum ister sayfanın kod bölümüne ekleyin isterse madülün içine kod bölümüne ekleyiniz.
mödülün içine ekleme yaparsanız bir modül içine yapıştırın
içinde CommandButton geçen bölümlerle ilgili Private yazan yerleri silin ve komut duğmesine bağlayıp çalıştırın


Private Sub CommandButton1_Click()
Private Sub CommandButton2_Click()
Private Sub CommandButton3_Click()


kod:

Kod: 
Private Sub CommandButton1_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

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (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 Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
If Right(yol, 1) <> "\" Then ekle = "\"
On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a" & Rows.Count)) + 1
Cells(j, 1) = yol & ekle & Dosya.Name
Cells(j, 2) = fL.GetBaseName(Dosya.Name) 'dosya.Name
Next

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

Set fL = Nothing
End Sub

Private Sub CommandButton2_Click()

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("c2:c65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
Exit Sub
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Klasor = fL.GetParentFolderName(eski)
dosya_adi = Worksheets(ActiveSheet.Name).Cells(i, 3).Value 'fL.GetBaseName(eski)
uzanti = "." & fL.GetExtensionName(eski)

yeni = Klasor & "\" & dosya_adi & uzanti
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni

Name eski As yeni
'FileCopy eski, yeni
Next i

MsgBox "işlem tamam"
End Sub


Private Sub CommandButton3_Click()

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("d2:d65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
Exit Sub
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "D").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 4).Value
yeni = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Name eski As yeni
Next i

Range("D2:D65000").ClearContents
MsgBox "işlem tamam"
End Sub
Yeni Bit Eşlem Resmi.jpg

Yeni Bit Eşlem Resmi1.jpgYeni Bit Eşlem Resmi (3).jpg
 

Ekli dosyalar

Son düzenleme:
H

Hyperhysv

Katılım
23 Mayıs 2014
Mesajlar
92
Excel Vers. ve Dili
2013 türkçe
Altın Üyelik Bitiş Tarihi
08/10/2021
merhaba;

macro aşağıdaki hatayı veriyor. sebebi nedir Name eski As yeni
Kod: 
Name eski As yeni
'FileCopy eski, yeni
'Worksheets(ActiveSheet.Name).Cells(i, 1).Value = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
'Worksheets(ActiveSheet.Name).Cells(i, 2).ClearContents
Next i
'Worksheets(ActiveSheet.Name).Cells(1, 3).Value = ""
MsgBox "işlem tamam"
End Sub
 
M

mrwarrior

Katılım
26 Ocak 2013
Mesajlar
232
Excel Vers. ve Dili
Excel 2016 Türkçe
Altın Üyelik Bitiş Tarihi
26-11-2023
halit3' Alıntı:
kodları sayfanın kod bölümüne koyun ve üç adet sayfaya komut düğmesi ekleyin (CommandButton1_Click) komut düğmesine tıklayın ve dosyaların adını değiştireceğiniz klasörü seçin ve tamamı tıklayın ilgili dosya isimleri A ve B sutünunda sıralanacaktır siz C sütünuna değişecek dosya adını yazınız ve (CommandButton2_Click) düğmesini tıklayınız. eğer işlemi geri almak istiyorsanız (CommandButton3_Click) düğmesini tıklayınız.

ayrıca diğer bir sayfada kod dosya uzantılarınıda değiştiriyor.

kod:

Kod: 
Private Sub CommandButton1_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

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (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 Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
If Right(yol, 1) <> "\" Then ekle = "\"
On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a" & Rows.Count)) + 1
Cells(j, 1) = yol & ekle & Dosya.Name
Cells(j, 2) = fL.GetBaseName(Dosya.Name) 'dosya.Name
Next

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

Set fL = Nothing
End Sub

Private Sub CommandButton2_Click()

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("c2:c65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
Exit Sub
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Klasor = fL.GetParentFolderName(eski)
dosya_adi = Worksheets(ActiveSheet.Name).Cells(i, 3).Value 'fL.GetBaseName(eski)
uzanti = "." & fL.GetExtensionName(eski)

yeni = Klasor & "\" & dosya_adi & uzanti
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni

Name eski As yeni
'FileCopy eski, yeni
Next i

MsgBox "işlem tamam"
End Sub


Private Sub CommandButton3_Click()

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("d2:d65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
Exit Sub
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "D").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 4).Value
yeni = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Name eski As yeni
Next i

Range("D2:D65000").ClearContents
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...
Allah razı olsun :) Çok işime yaradı. Teşekkürler
 
F

firatdikmen

Katılım
25 Şubat 2023
Mesajlar
1
Excel Vers. ve Dili
excel 2019 TR
bu hatayı bende aldım. ilkinde almamıştım ad değişmiyordu. şu an bu hatayı veriyor. değiştirmşyor. butoanlarda pasifleşti. buton eklemede makroyu görmüyor. ama 6 yıl geçmiş mesaja bakan yok.

Konuyu hortlatayım biraz :)

Hyperhysv' Alıntı:
merhaba;

macro aşağıdaki hatayı veriyor. sebebi nedir Name eski As yeni
Kod: 
Name eski As yeni
'FileCopy eski, yeni
'Worksheets(ActiveSheet.Name).Cells(i, 1).Value = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
'Worksheets(ActiveSheet.Name).Cells(i, 2).ClearContents
Next i
'Worksheets(ActiveSheet.Name).Cells(1, 3).Value = ""
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...
 
K

KARTAL133

Katılım
12 Şubat 2009
Mesajlar
185
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Altın Üyelik Bitiş Tarihi
05-11-2024
Merhabalar

dosya yollunu seçmedne yolu sabitliyerek yapa bilirmiyiz.
 
U

uysal_42

Katılım
22 Temmuz 2019
Mesajlar
4
Excel Vers. ve Dili
2016
Merhaba,
elimde böyle bir makro var.
dosya isimlerini bununla değiştirebiliyorum.
fakat alt klasörlerdeki dosyaları değiştiremiyorum.
alt klasörlerdeki dosyaların isimlerini değiştirmem için ne yapmam gerekiyor. yardımcı olabilir misiniz.

Sub dosyalaraisimver()
Dim Rky As Object, Klasor As Object, Evn As Object, i%
Set Rky = Interaction.CreateObject("Scripting.FileSystemObject")
Set Klasor = Rky.GetFolder("C:\Yeni klasör").Files
For Each Evn In Klasor
For i = 1 To Range("A65536").End(3).Row
If Replace(Evn.Name, ".pdf", "") = Cells(i, 1).Value Then
Evn.Name = Replace(Evn.Name, Cells(i, 1).Value, Cells(i, 2).Value)
End If
Next i
Next Evn
i = Empty: Set Evn = Nothing: Set Klasor = Nothing: Set Rky = Nothing
End Sub
 
K

KARTAL133

Katılım
12 Şubat 2009
Mesajlar
185
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Altın Üyelik Bitiş Tarihi
05-11-2024
Merhaba

Örnek Dosya atabilirmisiniz.
ben hiç bir sey çalışmadı
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst