Skip to main content

AccessTr.neT


Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle

Mehmet Emin Alkan
Mehmet Emin Alkan
3
678

Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle

Çözüldü #1
Arkadaşlar hayırlı akşamlar
Elimdeki Excel dosyasında sayfa1 de A sütununda yazılan değeri /GÖNDERİLECEK RESİMLER/ klasöründe varsa dosya yolunu E Sütunan yazdırılacak. ve aynı şekilde Sayfa2 de düşey ara ile A ve B sütunlarını Sayfa1 de B ve C sütunlarına getirmesini istiyorum. Şimdiden Teşekkürler

https://s6.dosya.tc/server2/a0whpv/Yeni_klasor.rar.html
Cevapla
#2
Merhaba.
Formülle resim olayını bilmiyorum.
Kod ile isterseniz ekte.Sayfada değişiklik durumunda çalışır.
Butona tıklama olatınada çavrilir yada kullanıcı tanımlı fonksiyonada çevrilebilir.

[Resim: do.php?img=11048]
https://resim.accesstr.net/do.php?img=11048

Private Sub Worksheet_Change(ByVal Target As Range)
Dim bul As Range, i As Long
Dim bulResim As String

With Sayfa3
    If Not Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then
        If Target.Rows.Count = 1 Then
            If Target.Value = "" Then
                Range(Cells(Target.Row, "B"), Cells(Target.Row, "E")).Value = "": Exit Sub
            End If
        End If

        If Target.Rows.Count = 1 Then
            Set bul = .Range("C:C").Find(Target.Value, , , 1)
            bulResim = noVarmi(Target.Value)
            If bulResim <> "" Then Target.Offset(, 4).Value = bulResim Else Target.Offset(, 4).Value = "Resim bulunamadý"
            If Not bul Is Nothing Then
                Range("B" & Target.Row & ":C" & Target.Row).Value = .Range("G" & bul.Row & ":H" & bul.Row).Value
            Else
                Range("B" & Target.Row & ":C" & Target.Row).Value = ""
            End If
        ElseIf Target.Rows.Count > 1 Then
            For i = Selection.Row To Target.Rows.Count + Selection.Row
                Set bul = .Range("C:C").Find(Cells(i, "A").Value, , , 1)
                bulResim = noVarmi(Cells(i, "A").Value)
                If bulResim <> "" Then
                    Cells(i, "E").Value = bulResim
                Else
                    If Cells(i, "A").Value = "" Then
                        Cells(i, "E").Value = ""
                    Else
                        Cells(i, "E").Value = "Resim bulunamadý"
                    End If
                End If
               
                If Not bul Is Nothing Then
                  Cells(i, "B").Value = .Range("G" & bul.Row)
                  Cells(i, "C").Value = .Range("H" & bul.Row)
                Else
                    Range(Cells(i, "B"), Cells(i, "C")).Value = ""
                End If
            Next
        End If
    End If
End With
Set bul = Nothing
End Sub

Function noVarmi(aranan) As String
Dim dosya As String, yol As String, parca As String
If CStr(aranan) = "" Then
    noVarmi = "": Exit Function
End If
parca = ThisWorkbook.Path & Application.PathSeparator & "GNDERLECEK RESMLER" & Application.PathSeparator
dosya = Dir(parca & "*.*")
noVarmi = ""
Do While dosya <> ""
    If dosya Like "*" & aranan & "*" Then
        noVarmi = parca & dosya: Exit Function
    End If
    dosya = Dir
Loop
End Function

.rar Yeni klasör.rar (Dosya Boyutu: 3,41 MB | İndirme Sayısı: 3)
Cevapla
#3
Konu cevaplanmışlara taşınmıştır.
Cevapla
#4
Sayın feraz bey
Teşekkürler. Konu çözüme kavuşturulmuştur.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task