Soru Excel Listesinden Klasördeki Fotoğraf İsimlerini Değiştirme

[hilmi0707]

Merhaba Arkadaşlar. Okulumudaki öğrencilerin e-okul fotoğraflarını güncellememiz gerekiyor. Bunun için her fotoğrafın adını ÖĞRENCİ NO ÖĞRENCİ ADI SOYADI şeklinde değiştirmemiz lazım.
2A sınıfına ait klasörde 26 adet resim var ve isimleri 2A1, 2A2, 2A3...2A26 şeklinde.

Excel listesinin ilk sütununda bu kodlar yazılı
Excel listesinin ikinci sütununda ise bu kodlara karşılık gelen öğrenci no ve ad-soyadları kayıtlı

2A1 345 HASAN HÜSEYİN YILMAZ
2A1 367 AYŞE YÜKSEKTEPE
2A3 450 FURKAN ADIGÜZEL

Örneğin 2A1 kodlu fotoğrafın ismini hemen 2A1 koduna karşılık gelen 345 HASAN HÜSEYİN YILMAZ olarak değiştirmek istiyoruz.

Forumda benzer konular var. Ama uygulamada sıkıntı çektik. Bazı konular da çok eski. Bu yüzden sizlerin yardımına ihtiyacımız var. Okulun bu işleri ile ben ilgileniyorum ve MAC kullanıcısıyım. Ama çözümleriniz WİN için de olursa okuldaki başka bir bilgisayarda uygulayabilirim.

Şimdiden teşekkür eder, güzel pazarlar dilerim...

 

[halit3]

kod:
not: C Sutununa yeni değişecek isim yazılacak

Sub dosyaları_bul()
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
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



Sub degistir()

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
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
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni
Next i

MsgBox "işlem tamam"
End Sub

 

[hilmi0707]

kod:
not: C Sutununa yeni değişecek isim yazılacak

Sub dosyaları_bul()
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
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



Sub degistir()

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
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
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni
Next i

MsgBox "işlem tamam"
End Sub

Ekli dosyayı görüntüle 209670

Teşekkür ederim
activex component can't create object 429 hatası alıyorum. Sanırım MacOs ile ilgili bir sıkıntı