klasörler içindeki excel dosya isimlerini klasör adı ile değiştirmek

[metinergul]

Arkadaşlar formlarda aradım ancak bulamadım kod yazmayı bilmediğim içinde mevcut olanların üzerinde değişiklik yaparak çözüme ulaşamadım
sorunum;
farklı klasörlerin içerisinde bulunan exel dosyalarının isimlerini, içinde bulunduğu klasörün ismi ile aynı yapmak istiyorum
örneğin klasör ismi metinergül.xls
bu klasörün içerisinde bulunan exel dosyasının ismi a1.xls
a1.xls ismini metinergül.xls nasıl yapabilirim
yardımcı olursanız çok memnun olurum.

 

[Murat OSMA]

Örnek;

Sub Emre()
    a = InStrRev(ThisWorkbook.Path, "\")
    b = Mid(ThisWorkbook.Path, a + 1, 50)
    klasör = ThisWorkbook.Path
    Name klasör & "\Excel.xls" As klasör & "\" & b & ".xls"
End Sub

Excel.xls dosyasını adını bulunduğu klasör adı ve ".xls" uzantısı olarak değiştirir.

 

[metinergul]

Örnek;

Sub Emre()
    a = InStrRev(ThisWorkbook.Path, "\")
    b = Mid(ThisWorkbook.Path, a + 1, 50)
    klasör = ThisWorkbook.Path
    Name klasör & "\Excel.xls" As klasör & "\" & b & ".xls"
End Sub

Excel.xls dosyasını adını bulunduğu klasör adı ve ".xls" uzantısı olarak değiştirir.

ilginiz için teşekkür ediyorum ancak ben bunu başaramadım
sanırım sorumu tam anlatamadım örnek dosyamın altında olan exel dosyalarının isimlerin kendi klasör isimleri yapmak istiyorum bu işlem için yazılan kodu örnek klasörünün içinde bir yeni bir exel doyasından mı yaptırmalıyız açıklamalı yardımcı olursanız çok memnun olurum

 

[halit3]

Alternatif kod:

Sub Dosyaların_adini_degistir()

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
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, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

say = 0
For Each dosya In fL.GetFolder(yol).Files
Uzanti = fL.GetExtensionName(dosya)
yer1 = fL.GetParentFolderName(dosya)
yer2 = fL.GetBaseName(yol)


If fL.GetFolder(yol).Files.Count = 1 Then
Name dosya As yer1 & "\" & yer2 & "." & Uzanti
Else
say = say + 1
Name dosya As yer1 & "\" & yer2 & say & "." & Uzanti
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[metinergul]

çok teşekkür ederim tam istediğim gibi olmuş.

 

[metinergul]

Alternatif kod:

Sub Dosyaların_adini_degistir()

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
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, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

say = 0
For Each dosya In fL.GetFolder(yol).Files
Uzanti = fL.GetExtensionName(dosya)
yer1 = fL.GetParentFolderName(dosya)
yer2 = fL.GetBaseName(yol)


If fL.GetFolder(yol).Files.Count = 1 Then
Name dosya As yer1 & "\" & yer2 & "." & Uzanti
Else
say = say + 1
Name dosya As yer1 & "\" & yer2 & say & "." & Uzanti
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

öncelikle ilginiz için çok teşekkür ediyorum
çözümleri birleştirerek hallederim diye düşündüğüm konuyu halledemediğim için sizden tekrar yardım istemek durumunda kaldım.
şöyleki örnek_1 klasörünün içersinde bulunan ana_dosya.xls dosyasındaki per_list kitabının L sütunun her satırındaki isimleri ana_dosya.xls dosyasının sözleşme kitabındaki a78 hücresine kaydedip, dosya ismini o isime çevirerek yeni açılacak aynı isimli klasöre kaydetmek istiyorum böylece personel listesindeki ismlere ait birer klasör ve içindede o personel isminde sözleşme dosyası (ad soyad.xls) oluşturmuş olacağım eğer yardımcı olursanız minnettar olurum

 

[halit3]

öncelikle ilginiz için çok teşekkür ediyorum
çözümleri birleştirerek hallederim diye düşündüğüm konuyu halledemediğim için sizden tekrar yardım istemek durumunda kaldım.
şöyleki örnek_1 klasörünün içersinde bulunan ana_dosya.xls dosyasındaki per_list kitabının L sütunun her satırındaki isimleri ana_dosya.xls dosyasının sözleşme kitabındaki a78 hücresine kaydedip, dosya ismini o isime çevirerek yeni açılacak aynı isimli klasöre kaydetmek istiyorum böylece personel listesindeki ismlere ait birer klasör ve içindede o personel isminde sözleşme dosyası (ad soyad.xls) oluşturmuş olacağım eğer yardımcı olursanız minnettar olurum

Ben sorunuzdan bir şey anlamadım.

Göndermiş olduğu klasör (örnek_1) bu bunun içindede
(ana_dosya.xls) dosyası var
Bu dosyanın içindede
1-(per_lis) sayfa,
2-(sözleşme) sayfa,
3-(Sayfa3) sayfa var


Şimdi siz nereden .xls uzantılı dosyayı oluşturuyorsunuz.

Herhalde bu uzantılı dosyayı oluşturan kod sizde

 

[metinergul]

anlaşılır şekilde anlatamadığım için özür dilerim
ana_dosya.xls elimde olan dosya
personel isimleri ana_dosya.xls dosyasında (per_lis) sayfasında,
sözleşme ana_dosya.xls dosyasının (sözleşme) sayfasında kayıtlı.
Birinci yapmak istediğim; (personel dosyaları) adlı yeni açılacak klasör içine her personele ayrı (kendi isminde) bir klasör oluşturmak(ana_dosya.xls deki per_lis sayfası ndaki isimler de).
İkincisi,her personelin klasörünün içine ana_dosya.xls soyasını (personel ismi).xls dosyası olarak kayıt etmek
Personel ismi.xls dosyasının sözleşme sayfasındaki A78 hücresine dosya ismindeki personelin ismi yazılacak.
Böylece ana_dosya.xls dosyasındaki personel listesine göre personel klasörü (ana klasör) içerisinde kendi isimlerinde birer klasörü o klasörlerin içerisinde de kendi isimlerinde (personel ismi). xls dosyası oluşmuş olacak
personelin sözleşmesinin çıktısı alınırken kişinin klasörüne girip dosyasını açmam yeterli olacaktır personelin sözleşmesinin dışında bir çok doküman ının olması durumunda kod yazmadan işin zorluğunu tahmin edersiniz.
Sorunumun kişiye özel bir sorun yardımcı olursanız sevinirim.
Elimde olan dosya ana_dosya.xls dosyasındaki isim soy isim listesine göre
Personel listesi (ana klasör)\personel ismi1\personel ismi1.xls şeklinde (personel ismi1.xls dosyasında (sözleşme) sayfasında a78 de personel ismi1 yazacak
Personel listesi (ana klasör)\personel ismi2\personel ismi2.xls şeklinde (personel ismi2.xls dosyasında (sözleşme) sayfasında a78 de personel ismi2 yazacak
Personel listesi (ana klasör)\personel ismi2\personel ismi2.xls şeklinde (personel ismi3.xls dosyasında (sözleşme) sayfasında a78 de personel ismi3 yazacak
vaktiniz olup ilgilenirseniz memnun olurum teşekkür ediyorum

 

[halit3]

anlaşılır şekilde anlatamadığım için özür dilerim
ana_dosya.xls elimde olan dosya
personel isimleri ana_dosya.xls dosyasında (per_lis) sayfasında,
sözleşme ana_dosya.xls dosyasının (sözleşme) sayfasında kayıtlı.
Birinci yapmak istediğim; (personel dosyaları) adlı yeni açılacak klasör içine her personele ayrı (kendi isminde) bir klasör oluşturmak(ana_dosya.xls deki per_lis sayfası ndaki isimler de).
İkincisi,her personelin klasörünün içine ana_dosya.xls soyasını (personel ismi).xls dosyası olarak kayıt etmek
Personel ismi.xls dosyasının sözleşme sayfasındaki A78 hücresine dosya ismindeki personelin ismi yazılacak.
Böylece ana_dosya.xls dosyasındaki personel listesine göre personel klasörü (ana klasör) içerisinde kendi isimlerinde birer klasörü o klasörlerin içerisinde de kendi isimlerinde (personel ismi). xls dosyası oluşmuş olacak
personelin sözleşmesinin çıktısı alınırken kişinin klasörüne girip dosyasını açmam yeterli olacaktır personelin sözleşmesinin dışında bir çok doküman ının olması durumunda kod yazmadan işin zorluğunu tahmin edersiniz.
Sorunumun kişiye özel bir sorun yardımcı olursanız sevinirim.
Elimde olan dosya ana_dosya.xls dosyasındaki isim soy isim listesine göre
Personel listesi (ana klasör)\personel ismi1\personel ismi1.xls şeklinde (personel ismi1.xls dosyasında (sözleşme) sayfasında a78 de personel ismi1 yazacak
Personel listesi (ana klasör)\personel ismi2\personel ismi2.xls şeklinde (personel ismi2.xls dosyasında (sözleşme) sayfasında a78 de personel ismi2 yazacak
Personel listesi (ana klasör)\personel ismi2\personel ismi2.xls şeklinde (personel ismi3.xls dosyasında (sözleşme) sayfasında a78 de personel ismi3 yazacak
vaktiniz olup ilgilenirseniz memnun olurum teşekkür ediyorum

Dosyadaki kod şu işlemi yapıyor dosyanın hemen yanına(Personel Dosyaları) klasörü oluşturuyor ve personel isimleri ile yeni klasör oluşturup sözleşme sayfasını personel ismi olarak (vb.xls dosya) kayıt yapıyor.

kod:

Sub çalışmakitabıyap()


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(dosya)
Uzanti = "." & fL.GetExtensionName(dosya)

yer = ThisWorkbook.Path & "\Personel Dosyaları"

If fL.FolderExists(yer) = False Then
MkDir yer
End If


For i = 3 To Worksheets("per_lis").Cells(Rows.Count, "B").End(3).Row
aranan1 = Sheets("per_lis").Cells(i, "L").Value

Kaynak = yer & "\" & aranan1
If fL.FolderExists(Kaynak) = False Then
MkDir Kaynak
End If

Sheets("sözleşme").Cells(78, "A").Value = aranan1

Sheets("sözleşme").Copy
Sheets(ActiveSheet.Name).Name = aranan1


If fL.GetFolder(Kaynak).Files.Count = 0 Then
ActiveWorkbook.SaveAs Kaynak & "\" & aranan1 & Uzanti
Else
say = fL.GetFolder(Kaynak).Files.Count
ActiveWorkbook.SaveAs Kaynak & "\" & aranan1 & say & Uzanti
End If


ActiveWorkbook.Close False

Next
MsgBox "İşlem tamam"

End Sub

 

[metinergul]

öncelikle emeğine ve bilgi paylaşımınıza çok teşekkür ediyorum çok güzel olmuş
ancak ifade etmediğim a78 hücresine kodla yazdırılan isim soy isim önüne "Adı Soyadı " yazdır mak ve bunları a78 hücresinin satırını ortalayarak yazdırmak mümkünmü? zaman ayırdığınız için tekrar teşekkür ediyorum. meti ergül

 

[halit3]

öncelikle emeğine ve bilgi paylaşımınıza çok teşekkür ediyorum çok güzel olmuş
ancak ifade etmediğim a78 hücresine kodla yazdırılan isim soy isim önüne "Adı Soyadı " yazdır mak ve bunları a78 hücresinin satırını ortalayarak yazdırmak mümkünmü? zaman ayırdığınız için tekrar teşekkür ediyorum. meti ergül

Sheets("sözleşme").Cells(78, "A").Value = aranan1

Yukarıdaki kodu silin ve aşağıdakini ekleyin.

Sheets("sözleşme").Cells(78, "A").Value = "Adı Soyadı " & aranan1
Sheets("sözleşme").Cells(78, "A").HorizontalAlignment = xlCenter

 

[metinergul]

Halit bey çok teşekkür ediyorum iyiki varsınız.