Listeye göre resimlerin ismin değiştirmek Makrosu

[meleklerim]

Arkadaşlar elimde uzun bir kişi listesi var.
Bu listedeki her kişinin bir numarası var. (TC diyelim)
Bu kişilerin resminin olduğu bir de resimler klasörü var.

Bu kişilerin resimleri kişinin adına göre değil de numarasına göre adlandırılmış.

Örnek
A1 hücresinde; "25465845"
b1 hücresinde; "Ali Yıldırım"

yazıyor.
Klasörde Ali Yıldırıma ait resmin adı:"25465845"

Ben Ali Yıldırım'a ait resmin adının: "Ali Yıldırım" olmasını istiyorum.
Böyle """listeye bak, a1 de yazan veriyle eşleşen resmi bul, resmin adını b1 de yazan yap" türü bir makro yazılabilir mi?

Yaklaşık 9500 civarında olduğu için elle yapmak çok zor.

ilgilenen arkadaşlara şimdiden teşekkürler

 

[Mustafa MUTLU]

xls 2003 formatında dosya eklerseniz bakabilirim

 

[meleklerim]

Buyrun Mustafa Bey,
teşekkürler

http://dosya.co/96f2whfrgyh4/ID_00.rar.html

 

[PLİNT]

Merhaba
Saygıdeğer Mustafa bey in hoşgörüsüyle; şöyle bir kod işinize yarayabilir.
Resimler excel dosyanızın yanında ise:

Sub isim_değiş()
Dim i As Long
Dim a
Dim h, h2 As String
Set a = CreateObject("scripting.filesystemobject")
For i = 2 To Cells(65536, "A").End(xlUp).Row
h = Dir(ThisWorkbook.Path & "\" & Cells(i, "A").Value & "*.*", vbDirectory)
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value)
If a.FileExists(ThisWorkbook.Path & "\" & h) = True Then
Name ThisWorkbook.Path & "\" & h As ThisWorkbook.Path & "\" & h2
End If
Next
End Sub

Diskte ise

 Sub isim_degistir()
Dim i As Long
Dim a
Dim h, h2 As String
Set a = CreateObject("scripting.filesystemobject")
For i = 2 To Cells(65536, "A").End(xlUp).Row
h = Dir("D:\Resimler\" & Cells(i, "A").Value & "*.*", vbDirectory)
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value)
If a.FileExists("D:\Resimler\" & h) = True Then
Name "D:\Resimler\" & h As "D:\Resimler\" & h2
End If
Next
End Sub

 

[meleklerim]

Örnek belgede çok güzel çalıştı, ancak gerçek dosyada
163. satırda durdu.

Name ThisWorkbook.Path & "\" & h As ThisWorkbook.Path & "\" & h2

bu satırda hata gösterdi
163 nolu Id nin adında başka bir ID si olan fakat aynı ada sahip bir giriş daha var. O ihtimali hiç düşünmemiştim.

Bu karışıklığı önlemek adına örnek dosyaya bir sütun daha ekledim.

http://s6.dosya.tc/server6/ufdlez/ID_01.rar.html

 

[PLİNT]

Merhaba
Kodlar içindeki "h2" tanımını şöyle değiştirirseniz "c" sütunundaki değeri isme ekler.

h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value & " " & Cells(i, "C").Value)

sadece adı aynı olan dosya varsa eklensin derseniz;

Sub isim_değiş()
Dim i As Long
Dim a
Dim h, h2 As String
Set a = CreateObject("scripting.filesystemobject")
For i = 2 To Cells(65536, "A").End(xlUp).Row
h = Dir(ThisWorkbook.Path & "\" & Cells(i, "A").Value & "*.*", vbDirectory)
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value)
If a.FileExists(ThisWorkbook.Path & "\" & h) = True Then
[COLOR="Blue"]If a.FileExists(ThisWorkbook.Path & "\" & h2) = True Then _
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value & " " & Cells(i, "C").Value)[/COLOR]
Name ThisWorkbook.Path & "\" & h As ThisWorkbook.Path & "\" & h2
End If
Next
End Sub

Önceki kodlarla değişen 162 dosya ismi içinde;
"c" sütunundan ekleme isterseniz kodlara ek yapalım.
veya "B" sütununu 162. satıra kadar kopyalayıp "A" sütunu 162. satıra kadar ("B2:B162" sütunuyla "A2:A162" aynı olacak şekilde) yapıştırıp
kodları çalıştırırsanız önceki değişenlerede "c" hücresindeki değeri ekler.

 

[meleklerim]

C sütunu işe dahil olunca yağ gibi aktı makro...
Hatta hem yılı hem ismi aynı olan 2 hatalı girişi de bu makro sayesinde düzelttim.
Çok sağolun gerçekten.
Son bir sorum olacak,
Diyelim aynı girişe 2 yada daha fazla resim eklenmiş.
O resimler de yine adını ID olarak almış. Doğal olarak aynı isim olamadığı için sözgelimi
4567 nolu Idye ait 3 resim 4567_01, 4567_02, 4567_03 olarak adlandırılmış
Bu durumda onların "Ali Yıldırım 1956 _01", "Ali Yıldırım 1956 _02", "Ali Yıldırım 1956 _03"
biçimine sokmak mümkün mü?
Tamamen makroyu anlamak adına soruyorum
Vaktiniz yoksa uğraşmasanız da olur, acelesi yok.
Tekrar çok teşekkürler, iyi ki varsınız

 

[PLİNT]

4567 nolu Idye ait 3 resim 4567_01, 4567_02, 4567_03 olarak adlandırılmış
Bu durumda onların "Ali Yıldırım 1956 _01", "Ali Yıldırım 1956 _02", "Ali Yıldırım 1956 _03"
biçimine sokmak mümkün mü?

Merhaba
Öyle bir durum varsa yukarıdaki kodların ilgili bölümünü (zararı olmayabilir ama) şöyle kullanın.

h = Dir(ThisWorkbook.Path & "\" & Cells(i, "A").Value [COLOR="Red"]& ".*"[/COLOR], vbDirectory)

Son isteğinize görede ek dosyadaki gibi olabilir. Bir deneyelim.
Klasördeki isimler "D" sütununa listelenip, "C" sütununa gerekli eklemeler yapılacak ve adları değiştirecek.
http://s6.dosya.tc/server6/lpwrjp/ID_01.zip.html

 

[meleklerim]

çok etkili bir makro olmuş. Bu ne sürat, maşallah...
elinize sağlık

 

[meleklerim]

bu makroda bir hatayla karşılaştım.


Sub IDNO_ISIMDEGIS()
Dim i As Long
Dim a
Dim h, h2 As String
Set a = CreateObject("scripting.filesystemobject")
For i = 2 To Cells(65536, "A").End(xlUp).Row
h = Dir(ThisWorkbook.Path & "\" & Cells(i, "A").Value & "*.*", vbDirectory)
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value & " " & Cells(i, "C").Value)
If a.FileExists(ThisWorkbook.Path & "\" & h) = True Then
Name ThisWorkbook.Path & "\" & h As ThisWorkbook.Path & "\" & h2
End If
Next
End Sub

bu makroyu kullanarak işimi hallediyordum.
Ancak 3 basamaklı ıd numaralrından sonra şöyle bir sorunla karşılaştım.
4 basamaklı Id numaralarında farklı davranıyor.
Şöyle ki
örneğin 4229 nolu kişinin resmine 422 nolu kişinin adını yazıyor ve sonuna 9 ekliyor

4229 Yılmaz Güney
422 Yeşim Salkım

Yılmaz Güneyin resmine Yeşim Salkım 9 yazıyor.
Sorun neden kaynaklanıyor acaba?
düzeltebilir misin?
İd numaralı 6 rakam kadar olabilir. hatta başında harf bile olabilir.
selamlar, saygılar şimdiden teşekkürler

 

[PLİNT]

Merhaba
#8 nolu (yukarıdaki) mesajımda "h" tanımlamasını değişmenizi o ihtimal için tavsiye etmiştim.
Aşağıdaki gibi değiştirerek deneyelim. ".*"

Sub IDNO_ISIMDEGIS()
Dim i As Long
Dim a
Dim h, h2 As String
Set a = CreateObject("scripting.filesystemobject")
For i = 2 To Cells(65536, "A").End(xlUp).Row
h = Dir(ThisWorkbook.Path & "\" & Cells(i, "A").Value &[COLOR="Red"] ".*"[/COLOR], vbDirectory)
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value & " " & Cells(i, "C").Value)
If a.FileExists(ThisWorkbook.Path & "\" & h) = True Then
Name ThisWorkbook.Path & "\" & h As ThisWorkbook.Path & "\" & h2
End If
Next
End Sub

 

[meleklerim]

evet, o satırı değiştirince hata kalmadı, çok teşekkürler

 

[meleklerim]

Merhaba
#8 nolu (yukarıdaki) mesajımda "h" tanımlamasını değişmenizi o ihtimal için tavsiye etmiştim.
Aşağıdaki gibi değiştirerek deneyelim. ".*"

Sub IDNO_ISIMDEGIS()
Dim i As Long
Dim a
Dim h, h2 As String
Set a = CreateObject("scripting.filesystemobject")
For i = 2 To Cells(65536, "A").End(xlUp).Row
h = Dir(ThisWorkbook.Path & "\" & Cells(i, "A").Value &[COLOR="Red"] ".*"[/COLOR], vbDirectory)
h2 = Replace(h, Cells(i, "A").Value, Cells(i, "B").Value & " " & Cells(i, "C").Value)
If a.FileExists(ThisWorkbook.Path & "\" & h) = True Then
Name ThisWorkbook.Path & "\" & h As ThisWorkbook.Path & "\" & h2
End If
Next
End Sub

Bu makroda şöyle bir hata farkettim, oluşturduğu dosya adında uzantısından önce bir boşluk bırakıyor.

Örneğin eski adı "1.jpg" olan resmi yeni adını "ahmet.jpg" yapmak istersek "ahmet .jpg" yapıyor.
Hangi satırdaki boşluğu silmek gerek yardımcı olabilir misiniz acaba?