Klasör içindeki dosya isimlerini tabloda yazılan isimlerle eşleştirmek

casusbelli · 26 Eylül 2012

Merhabalar,
forumda aradım ancak belki derdimi tam olarak ifade edemediğimden belki de yanlış kelimeleri aradığımdan dolayı bulamadım ve bu başlığı açmak zorunda kaldım.

Sorunum şöyle: elimde bir klasör içinde TC Kimlik numaraları ile kaydedilmiş öğrenci resimleri var -yaklaşık 600 kadar- bir excel çalışma kitabına kaydedilmiş olan öğrenci isimlerinin karşısına resminin var olup olmadığını göstermek istiyorum. Eğer öğrenci resmi varsa bir hücreye "RESMİ VAR" yazıp sonraki hücreye resmin gösterilmesini, eğer resim yok ise " RESİM EKLENMEMİŞ" yazıp yandaki hücreye resimsiz.jpg isimli dosyanın gösterilmesini istiyorum.
Yol gösterirseniz sevinirim

halit3 · 26 Eylül 2012

Kodu sayfanın kod bölümüne ekleyin

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c2:c65536]) Is Nothing Then Exit Sub
yatay = 2 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") <> 0 Then
Exit Sub
End If
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Adres = Worksheets(ActiveSheet.Name).Cells(Target.Row + dikey, Target.Column + yatay).Address
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If yer = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture
deg2 = 0
klasor = CreateObject("wscript.Shell").SpecialFolders("Desktop") & "\ogrenciler\2013\"
Dim uzanti(3)
uzanti(1) = "jpg":
uzanti(2) = "bmp":
uzanti(3) = "gif":
For j = 1 To 3
If CreateObject("Scripting.FileSystemObject").FileExists(klasor & Target.Value & "." & uzanti(j)) = True Then
ActiveSheet.Pictures.Insert(klasor & Target.Value & "." & uzanti(j)).Select
Selection.Top = Val(Target.Offset(dikey, yatay).Top + 4)
Selection.Left = Val(Target.Offset(dikey, yatay).Left + 4)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Val(Target.Offset(dikey, yatay).Height - 6)
Selection.ShapeRange.Width = Val(Target.Offset(dikey, yatay).Width - 6)
Cells(Target.Row, 4).Value = "VAR"
Cells(Target.Row + 1, Target.Column).Select
deg2 = 1
Exit For
End If
Next
If deg2 = 0 Then
ActiveSheet.Pictures.Insert(klasor & "resimsiz.jpg").Select
Selection.Top = Val(Target.Offset(dikey, yatay).Top + 4)
Selection.Left = Val(Target.Offset(dikey, yatay).Left + 4)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Val(Target.Offset(dikey, yatay).Height - 6)
Selection.ShapeRange.Width = Val(Target.Offset(dikey, yatay).Width - 6)
Cells(Target.Row, 4).Value = "YOK"
Cells(Target.Row + 1, Target.Column).Select
End If
End Sub

casusbelli · 27 Eylül 2012

Ellerinize sağlık, gerçekten çok işime yarayacak bir tablo oldu.

halit3 · 27 Eylül 2012

casusbelli' Alıntı:
Ellerinize sağlık, gerçekten çok işime yarayacak bir tablo oldu.

İyi çalışmalar

m_yektam · 26 Eylül 2018

Halit Bey Merhabalar;

Üsttekine benzer bir ihtiyaç da bende var. Aynı kodu kullanmak istedim ama bana uygun şekilde düzenleyemedim. Bu konularda sizin kadar iyi değilim maalesef. Bendeki durum ise şu şekilde.

Exceldeki tabloda D sütununda yazan dosya isimleri ile klasör içindeki PDF'lerin eşleşmesi gerekiyor. Klasör içerisinde PDF dosyasının var yada yok durumuna göre, excel tablosunda p sütununda ki scan report başlığı altında "VAR" yada "YOK" yazması gerekiyor. Kullandığım excel ingilizce bundan dolayı olmuyor sanırım. Yardımlarınızı bekliyorum. Şimdiden çok teşekkür ederim.

halit3 · 26 Eylül 2018

kod

PHP:

Sub Klasorden_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
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
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 fs As Object, f As Object, t As Long

Set fs = CreateObject("Scripting.FileSystemObject")
uzanti = "PDF"

For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
If fs.FileExists(yol & "\" & aranan & "." & uzanti) = True Then
Cells(t, "P").Value = "VAR"
Else
Cells(t, "P").Value = "YOK"
End If
Next t


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

m_yektam · 26 Eylül 2018

Çok teşekkürederim. Mükemmel oldu. Ama küçük bir sorun çıktı. Şöyleki, bu PDF dosyaları Server'da ve dosyaları içeren klasörü seçerken Server'dan seçim yapamıyorum. Çıkan pencerede yok. Bu excel dosyasını direk dosyaların olduğu klasörün içine atsam ve kendisininde içinde olduğu klasörü tarayabilse olur mu?

halit3 · 26 Eylül 2018

Buyurun bakalım

PHP:

Sub Klasorden_dosyaları_bul()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (ThisWorkbook.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)
Dim fs As Object, f As Object, t As Long

Set fs = CreateObject("Scripting.FileSystemObject")
uzanti = "PDF"

For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
If fs.FileExists(yol & "\" & aranan & "." & uzanti) = True Then
Cells(t, "P").Value = "VAR"
Else
Cells(t, "P").Value = "YOK"
End If
Next t


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

m_yektam · 27 Eylül 2018

Çok güzel çalıştı. Biraz fazla oluyorsun diyebilirsin ama şöyle bi sıkıntı var. Kodu yazıp kaydedip çalıştırıyorum sıkıntısız çalışıyor. Sonra exceli çıkmadan yine kaydediyorum çıkıyorum. Tekrar girince "VAR" yok "YOK" hücreleri dolu, yani en son kaydettiğim şekilde duruyor excel. Ancak ALT+F8 yapıp kodu tekrar çalıştırmak istediğimde kod görülmüyor. Tekrar ALT+F11 yapıp kodu tekrar kaydetmem gerekiyor.

Ne denediysem olmadı. Dosyaları serverdan çıkartıp masaüstüne aldım orda denedim. Kod çalışıyor ancak exceli kapatıp açtığımda kod excelden silinmiş oluyor. Nedeni ne olabilir

Tevfik_Kursun · 27 Eylül 2018

Merhaba,
Belki dosyayı makrolu dosya DosyaAdi.xlsm şeklinde kayıt etmiyorsunuz.
İyi çalışmalar

halit3 · 27 Eylül 2018

Evet Tevfik Beyin dediği gibi dosyayı kayıt yaparken farklı kayıtlardan xlms uzantılı kayıt yapmanız gerekiyor.
makrolar xlsx uzantılı dosyalarda çalışır ama dosyayı kapatıp yeniden açtığınızda makrolar silinmiş olarak gelir yani xlsx dosyada makro varsa dosyayı kapattığınızda makroları siler

m_yektam · 27 Eylül 2018

Tevfik_Kursun' Alıntı:
Merhaba,
Belki dosyayı makrolu dosya DosyaAdi.xlsm şeklinde kayıt etmiyorsunuz.
İyi çalışmalar

halit3' Alıntı:
Evet Tevfik Beyin dediği gibi dosyayı kayıt yaparken farklı kayıtlardan xlms uzantılı kayıt yapmanız gerekiyor.
makrolar xlsx uzantılı dosyalarda çalışır ama dosyayı kapatıp yeniden açtığınızda makrolar silinmiş olarak gelir yani xlsx dosyada makro varsa dosyayı kapattığınızda makroları siler

Evet oldu. Tevfik ve Halit Bey. İkinizede çok teşekkür ederim.

Özellikle Halit Bey sayenizde hem zamandan tasarruf edilecek, hemde dikkat gerektiren bir iş olduğu için, işin daha doğru olması sağlanacak. Tekrar teşekkürler.

İyi günler dilerim.

m_yektam · 27 Eylül 2018

Halit Bey;

Bu Excel'in sonu yok. İnsan sürekli "bunuda yapamaz artık" diyor ama her seferinde excel insanı şaşırtıyor.

Aklıma birşey geldi ama excel ile yapılırmı bilemiyorum. Aklıma gelen ise;

Aynı excel tablosu üzerinden konuşmak gerekirse, B ve C sütunlarında PDF dosyalarının içeriği hakkında bilgiler bulunmaktadır. Örneğin; B sütununda yazan "20UMA" kodunun içeren yada C sütununda yazan "Workshop Building" isimli birçok PDF dosyası klasör içinde mevcut. Ben filtre ile bu PDF'leri istediğim şekilde excelde listeleyebiliyorum. Peki bu filtre ile sadece filtrelediğim PDF dosyalarını klasör içinde görünür, filtre ile kapattığım dosyaları ise görünmez hale getirebilirmiyim?

Olabileceği bile mechul olan bir işi anlatmakta biraz zorlandım. İnşallah anlaşılır olmuştur.

m_yektam · 20 Kasım 2018

Varmı konu ile ilgili yardımcı olabilecek biri?

beherzt · 29 Ocak 2020

Merhabalar

Arkadaşlar elimde ki excel dosyasında A sütünunda ürün isimleri, B sütünunda ürünün resim linkleri bulunan bir liste var. Şimdi ben bu listedeki resimleri hepsini indirip dosya adının da A sütünu ile değiştirilmesini istiyorum yardımcı olurmusunuz?

tahsinanarat · 25 Şubat 2020

halit3' Alıntı:

Buyurun bakalım

PHP:

Sub Klasorden_dosyaları_bul()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (ThisWorkbook.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)
Dim fs As Object, f As Object, t As Long

Set fs = CreateObject("Scripting.FileSystemObject")
uzanti = "PDF"

For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
If fs.FileExists(yol & "\" & aranan & "." & uzanti) = True Then
Cells(t, "P").Value = "VAR"
Else
Cells(t, "P").Value = "YOK"
End If
Next t


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

Sayın @halit3 hocam yukarıdaki kodda d sutunu ile klasörde isimleri eşleşen dosyalara var yok yazıyor. Ben Klasör içinde D sutunundaki kelimeyi Klasördeki dosya isimleri içinde geçiyorsa da VAR yazmasını, geçmiyorsa YOK yazdırmak istersem koda nasıl bir ilave yapmalıyız. Benim Klasörümdeki dosya isimleri TC no adı soyadı ve sicili şeklinde, bu sıralama bazen karışık da olabiliyor, bu yüzden TC nin geçtiği dosyayı bulduğunda VAR yazmasını bulamadığında YOK yazmasını istiyorum. Saygılarımla

halit3 · 25 Şubat 2020

Bunu bir deneyin

Kod:

Sub Klasorden_dosyaları_bul()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (ThisWorkbook.Path)
MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)
Dim fs As Object, f As Object, t As Long
Set fs = CreateObject("Scripting.FileSystemObject")
For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
bulunan = fs.GetBaseName(Dosya.Name)
If bulunan Like "*" & Trim(aranan) & "*" = True Then
Cells(t, "P").Value = "VAR"
GoTo atla
End If
Next
Cells(t, "P").Value = "YOK"
atla:
Next t

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

tahsinanarat · 25 Şubat 2020

sn. @halit3 Hocam

Kod:

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files

satırında hata verdi.

halit3 · 25 Şubat 2020

kodun bu bölümündeki klasor ismini silin ben denemek için yazmıştım orada kalmış,

Rich (BB code):

Liste (ThisWorkbook.Path & "\dosyalar")

tahsinanarat · 25 Şubat 2020

Sn. @halit3 onu silip denediğimde sonsuz döngüye giriyor, ctrl+alt+deletle sonlandırmak zorunda kalıyorum.

Klasör içindeki dosya isimlerini tabloda yazılan isimlerle eşleştirmek

casusbelli

Ekli dosyalar

halit3

Uzman

casusbelli

halit3

Uzman

m_yektam

Ekli dosyalar

halit3

Uzman

m_yektam

halit3

Uzman

m_yektam

Tevfik_Kursun

halit3

Uzman

m_yektam

m_yektam

m_yektam

beherzt

tahsinanarat

halit3

Uzman

tahsinanarat

halit3

Uzman

tahsinanarat