• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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
 
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:
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
 
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
 
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 ...
 
Merhabalar

dosya yollunu seçmedne yolu sabitliyerek yapa bilirmiyiz.
 
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
 
Merhaba

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