Ana klasöre bağlı eşleştirme yaparak alt klasörleri dolu yada boş olmasına göre excel'e veri yazdırmak

Hoksisamuray1 · 27 Eylül 2024

Merhabalar, Benim ekli kodum var. Burada B sütünündaki mağaza koduna göre ana dosya olan “Lokasyon Görseller” altındaki klasörlerin mağaza kodları uyuşanları buluyor ve bu klasörlere ait H sütunundaki ilgili hücreye link ekliyor.

Ama benim aslında yapmak istediğim B sütünündaki mağaza koduna göre ana dosya olan “Lokasyon Görseller” altındaki klasörlerin mağaza kodları uyuşanları bulsun. Bulduğu klasörler içinde dosya varmı baksın.
Eğer klasör bulunamazsa "Klasör Bulunamadı", klasör var ama görsel yoksa "Görsel Yok", görsel varsa "Görsel Var" şeklinde H sütunundaki ilgili hücreye not ve link eklensin istiyorum. Bu sayede linkini getirdiğim klasörlerden hangisinde görsel var veya yok bileyim. Buna konuda yardımcı olabilir misiniz?

Sub KlasorleriBulVeLinkEkle()
Dim ws As Worksheet
Dim cell As Range
Dim MagazaID As String
Dim lastModifiedFolder As String
Dim lastModifiedDate As Date

' Çalışma sayfasını tanımlayın (müşteri listesi olan sayfa)
Set ws = ThisWorkbook.Sheets("TR_RawData") ' Gerekirse sayfa adını güncelleyin

' Tarama yapılacak ana klasörleri tanımlayın
Dim klasorler(1 To 19) As String
klasorler(1) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Aday"
klasorler(2) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Aktif"
klasorler(3) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Pasif"
klasorler(4) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Aday"
klasorler(5) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Aktif"
klasorler(6) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Pasif"
klasorler(7) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\Aday"
klasorler(8) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\ Aktif"
klasorler(9) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\ Pasif"
klasorler(10) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Aday"
klasorler(11) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Aktif"
klasorler(12) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Pasif"
klasorler(13) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Aday"
klasorler(14) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Aktif"
klasorler(15) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Pasif"
klasorler(16) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Aday"
klasorler(17) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Aktif"
klasorler(18) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Pasif"
klasorler(19) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Seyhanlar\Pasif"

' B sütunundaki MağazaID'leri tarar (örneğin, B2'den başlar)
For Each cell In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
MagazaID = cell.Value ' B sütunundaki MağazaID'yi alır

' En güncel klasör bilgilerini sıfırlayın
lastModifiedDate = 0
lastModifiedFolder = ""

' Her klasör yolu için arama yap
Dim i As Integer
For i = LBound(klasorler) To UBound(klasorler)
Call KlasorleriTara(klasorler(i), MagazaID, lastModifiedFolder, lastModifiedDate)
Next i

' En güncel klasör bulunduysa, H sütununa link ekle
If lastModifiedFolder <> "" Then
ws.Cells(cell.Row, "H").Hyperlinks.Add Anchor:=ws.Cells(cell.Row, "H"), _
Address:=lastModifiedFolder, TextToDisplay:="Klasör Linki"
Else
ws.Cells(cell.Row, "H").Value = "Klasör Bulunamadı"
End If
Next cell

MsgBox "Tüm MağazaID'ler için klasörlerde arama tamamlandı.", vbInformation
End Sub

' Alt klasörlerde tarama yapan rekürsif fonksiyon
Sub KlasorleriTara(klasorYolu As String, MagazaID As String, ByRef lastModifiedFolder As String, ByRef lastModifiedDate As Date)
Dim file As String
Dim folderPath As String
Dim folderDate As Date

' İlk olarak mevcut klasörde MağazaID ile başlayan klasörleri kontrol edin
file = Dir(klasorYolu & "\" & "*" & MagazaID & "*", vbDirectory)

Do While file <> ""
If (GetAttr(klasorYolu & "\" & file) And vbDirectory) = vbDirectory Then
folderPath = klasorYolu & "\" & file

' Klasörün gerçekten var olup olmadığını kontrol edin
If Dir(folderPath, vbDirectory) <> "" Then
' Klasörün son değiştirilme tarihini al
folderDate = FileDateTime(folderPath)

' Eğer bu klasör en güncel klasörse bilgileri sakla
If folderDate > lastModifiedDate Then
lastModifiedDate = folderDate
lastModifiedFolder = folderPath
End If
End If
End If

' Sonraki klasöre geç
file = Dir
Loop
End Sub

Biolightant · 28 Eylül 2024

Merhaba,
Mağza (AVM, Belediye... ) isimlerinin olduğu Klasörlerin için de
Aday veya Aktif veya Pasif ismin de Resim dosyaları var

B sütünün da Mağza isimleri var
Sonuçları H hücresinde görmek istiyorsunuz.

Doğru anladıysam.

C++:

Private Sub Worksheet_Change(ByVal Target As Range)

    ' Eğer Değişen Sütün = B(2) ise yap
    If Target.Column = 2 Then
        KlasorKontrol Target.Value, Target.Row
    End If

End Sub

Private Sub KlasorKontrol(Magza As String, MesajSatir As Long)

    Dim KlasorYolu As String
    KlasorYolu = "C:\Users\info\Pictures\" ' Mağzaların bulunduğu klasör yolunu yazınız
    KlasorYolu = KlasorYolu & Magza
    
    ' H hücresindeki mevcut link varsa sil
    If Range("H" & MesajSatir).Hyperlinks.Count > 0 Then
        Range("H" & MesajSatir).Hyperlinks.Delete
    End If
    
    ' Kontrol etmek için FileSystemObject oluştur
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Klasör var mı kontrol et
    If Not fso.FolderExists(KlasorYolu) Then
        Range("H" & MesajSatir).Value = "Klasör yok"
    Else
        ' Klasördeki dosyaları kontrol et
        Dim klasor As Object
        Dim dosya As Object
        Dim resimVar As Boolean
        resimVar = False
        
        Set klasor = fso.GetFolder(KlasorYolu)
        
        For Each dosya In klasor.Files
            ' Dosya isimlerinde "Aday", "Aktif" veya "Pasif" olup olmadığını kontrol et
            If InStr(1, dosya.Name, "Aday", vbTextCompare) > 0 Or _
               InStr(1, dosya.Name, "Aktif", vbTextCompare) > 0 Or _
               InStr(1, dosya.Name, "Pasif", vbTextCompare) > 0 Then
                ' Eğer bu kelimelerden biri varsa, dosya bulundu
                resimVar = True
                
                ' Yeni linki ekle
                Range("H" & MesajSatir).Hyperlinks.Add Anchor:=Range("H" & MesajSatir), Address:=dosya.Path, TextToDisplay:=Dir(dosya.Path)
                
                Exit For
            End If
        Next dosya
        
        ' Eğer klasörde uygun isim de Resim Dosyası yoksa
        If Not resimVar Then
            Range("H" & MesajSatir).Value = "Resim yok"
        End If
    End If
    
    ' Belleği temizle
    Set fso = Nothing
    Set klasor = Nothing
    Set dosya = Nothing

End Sub

Hoksisamuray1 · 2 Ekim 2024

Biolightant' Alıntı:

Merhaba,
Mağza (AVM, Belediye... ) isimlerinin olduğu Klasörlerin için de
Aday veya Aktif veya Pasif ismin de Resim dosyaları var

B sütünün da Mağza isimleri var
Sonuçları H hücresinde görmek istiyorsunuz.

Doğru anladıysam.

C++:

Private Sub Worksheet_Change(ByVal Target As Range)

    ' Eğer Değişen Sütün = B(2) ise yap
    If Target.Column = 2 Then
        KlasorKontrol Target.Value, Target.Row
    End If

End Sub

Private Sub KlasorKontrol(Magza As String, MesajSatir As Long)

    Dim KlasorYolu As String
    KlasorYolu = "C:\Users\info\Pictures\" ' Mağzaların bulunduğu klasör yolunu yazınız
    KlasorYolu = KlasorYolu & Magza
   
    ' H hücresindeki mevcut link varsa sil
    If Range("H" & MesajSatir).Hyperlinks.Count > 0 Then
        Range("H" & MesajSatir).Hyperlinks.Delete
    End If
   
    ' Kontrol etmek için FileSystemObject oluştur
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    ' Klasör var mı kontrol et
    If Not fso.FolderExists(KlasorYolu) Then
        Range("H" & MesajSatir).Value = "Klasör yok"
    Else
        ' Klasördeki dosyaları kontrol et
        Dim klasor As Object
        Dim dosya As Object
        Dim resimVar As Boolean
        resimVar = False
       
        Set klasor = fso.GetFolder(KlasorYolu)
       
        For Each dosya In klasor.Files
            ' Dosya isimlerinde "Aday", "Aktif" veya "Pasif" olup olmadığını kontrol et
            If InStr(1, dosya.Name, "Aday", vbTextCompare) > 0 Or _
               InStr(1, dosya.Name, "Aktif", vbTextCompare) > 0 Or _
               InStr(1, dosya.Name, "Pasif", vbTextCompare) > 0 Then
                ' Eğer bu kelimelerden biri varsa, dosya bulundu
                resimVar = True
               
                ' Yeni linki ekle
                Range("H" & MesajSatir).Hyperlinks.Add Anchor:=Range("H" & MesajSatir), Address:=dosya.Path, TextToDisplay:=Dir(dosya.Path)
               
                Exit For
            End If
        Next dosya
       
        ' Eğer klasörde uygun isim de Resim Dosyası yoksa
        If Not resimVar Then
            Range("H" & MesajSatir).Value = "Resim yok"
        End If
    End If
   
    ' Belleği temizle
    Set fso = Nothing
    Set klasor = Nothing
    Set dosya = Nothing

End Sub

Eyvallah hocam eline sağlık. Ben cevap gelmeyince umudu kesmiştim sonra çözümü başka taraftan halletmiştim. Bu koduda deneyeceğim. Emeğine sağlık

Ana klasöre bağlı eşleştirme yaparak alt klasörleri dolu yada boş olmasına göre excel'e veri yazdırmak

Hoksisamuray1

Enes Kolbaş

Biolightant

Hoksisamuray1

Enes Kolbaş