JPEG formatındaki dosya ismi ile exceldeki ismin eşleştirmesi..

[tahiroglu]

Merhabalar.İşletmemizde işleme aldığımız ürünlerin fotoğraflarını çekiyoruz.Ve her ürünün bir kodu var.Bu kodlarda excel formatında kaydını gerçekleştiriyoruz.Çektiğimiz fotoğraflar JPEG formatında ve fotoğrafın dosya ismi ürünün kodu olarak değiştiriyoruz.Yani TR421041.jpeg olarak kaydı gerçekleşiyor.
çekilmiş olan tüm resimler masa üstünde klasör içinde saklı duruyor.

Benim sormak istediğim excelde sütunda altalta sıralı olan bu kodların makro yazımı ile masa üstündeki fotoğrafların bulunduğu klasör içindeki dosya isimleri ile karşılaştırıp eşleşmeyeni(aynı koddan olmayanı) uyarı vermesi.
BÖyle bir şeyi gerçekleştirebilirmiyiz.?
Yardımlarınızı bekliyorum.

 

[halit3]

Merhabalar.İşletmemizde işleme aldığımız ürünlerin fotoğraflarını çekiyoruz.Ve her ürünün bir kodu var.Bu kodlarda excel formatında kaydını gerçekleştiriyoruz.Çektiğimiz fotoğraflar JPEG formatında ve fotoğrafın dosya ismi ürünün kodu olarak değiştiriyoruz.Yani TR421041.jpeg olarak kaydı gerçekleşiyor.
çekilmiş olan tüm resimler masa üstünde klasör içinde saklı duruyor.

Benim sormak istediğim excelde sütunda altalta sıralı olan bu kodların makro yazımı ile masa üstündeki fotoğrafların bulunduğu klasör içindeki dosya isimleri ile karşılaştırıp eşleşmeyeni(aynı koddan olmayanı) uyarı vermesi.
BÖyle bir şeyi gerçekleştirebilirmiyiz.?
Yardımlarınızı bekliyorum.

örnek dosyanızı koysaydınız bi cevap veren belki çıkardı şimdi kodları yazdım kodları kendinize uyarlayınız.

A sütununna aranan dosya isimlerini yazınız.
B sütununa bulunan dosyaları yazıyor olmayan dosyalarıda yok yazıyır.

Sub resimeslestir()
On Error Resume Next
Dim Baslik As String
Baslik = "Resimler Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
son = 0
sat = sat + 1
kolon = [a65536].End(3).Row
For i = 1 To kolon
If Cells(i, 1).Value = Dosya.Name Then
Cells(sat, 2).Value = Dosya.Name
son = 1
i = kolon
End If
Next
If son = 0 Then
Cells(sat, 2).Value = "Dosya yok"
End If
Next
Else
Atla:
MsgBox "Lütfen Resimler Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

 

[tahiroglu]

ilginize teşekkür ederim dosya ekledim..
içinde biraz daha detaylı anlatmaya çalıştım..Yardımlarınızı bekliyorum..

 

[halit3]

123 tane mesajınız olmuş birazcık acemiliğiniz gitmiş örnek dosyanız olsaydı 1 sefer uğraşılacaktı. şimdi kodları yeniden düzenlemek gibi bir daha uğraştık umarım bunları dikkate alırsınız.

aşağıdaki kodu modüllün içine koyunuz ve deneyiniz.

Sub resimeslestir()
On Error Resume Next
Dim Baslik As String
Baslik = "Resimler Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
kolon = [a65536].End(3).Row
Range("B1:C" & kolon).ClearContents
For i = 1 To kolon
son = 0
aranan = Cells(i, 1).Value
For Each Dosya In CreateObject("Scripting.FileSystemObject"). GetFolder (Kaynak).Files
If Right(Dosya.Name, 4) = "jpeg" Then
If aranan = Mid(Dosya.Name, 1, Len(Dosya.Name) - 5) Then
Cells(i, 2).Value = Mid(Dosya.Name, 1, Len(Dosya.Name) - 5)
son = 1
End If
End If
Next
If son = 0 Then
Cells(i, 3).Value = "Dosya yok"
End If
Next
Else
Atla:
MsgBox "Lütfen Resimler Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

 

[halit3]

kodu yeniden düzenledim üsteki mesajda

 

[tahiroglu]

haklısınız zahmet ettim size bunun için kusura bakmayı..
formülde sadece
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFold er(Kaynak).Files

bu kısımda hata veriyor son kez bakabilirseniz memnun olurum...
(tekrar affınıza sığınırım sizi yordum)

 

[halit3]

GetFold er
yukarıdaki cümleyi birleştirin

aşağıdaki gibi yapın
GetFolder

 

[tahiroglu]

hocam uygulamay çalıştım fakat şöyle bir sorun var..olanları ve olmayanları belli etmiyor.sadece C sütununa dosya yok ibaresi çıkıyor.Olanları belirleyip olmayanları C sütununa dosya yok ibaresi koyması mümkünmü.Bu kodla hepsine dosya yok diyor.Örnek olarak bir kaç resimde gönderdim.inceleyebilirseniz sevinirim..

 

[halit3]

1 nolu mesajında .jpeg uzantısı olarak belli etmişsin
bende kodu buna göre yazmıştım siz bazı taraflarını değiştirmişsiniz. eksik olan
aşağıdaki satırıda düzeltmelisiniz.

If Right(dosya.Name, 3) = "jpeg" Then

bununla değiştirin

If Right(dosya.Name, 3) = "jpg" Then

 

[tahiroglu]

çok teşekkür ederim..emeğinize sağlık..Gerçekten büyük bir eziyetten kurtardınız minnettarım...iyi günler dilerim..

 

[halit3]

çok teşekkür ederim..emeğinize sağlık..Gerçekten büyük bir eziyetten kurtardınız minnettarım...iyi günler dilerim..

iyi çalışmalar

 

[halit3]

bu kod daha hızlı buluyor

Sub dosya_ara()
On Error Resume Next
Dim Baslik As String
Baslik = "Resimler Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Dim ds, a
kolon = [a65536].End(3).Row
Range("B1:C" & kolon).ClearContents
For i = 1 To kolon
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Kaynak & "\" & Cells(i, 1).Value & ".jpg")
If a = True Then
Cells(i, 2).Value = Cells(i, 1).Value
Else
Cells(i, 3).Value = "dosya yok"
End If
Next
Else
Atla:
MsgBox "Lütfen Resimler Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub