AccessTr.neT
Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle (/konu-klasordeki-resmin-dosya-yolunu-alma-ve-dusey-ara-vba-ile.html)



Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle - Mehmet Emin Alkan - 20/05/2021

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


Re: Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle - feraz - 21/05/2021

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




RE: Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle - feraz - 31/05/2021

Konu cevaplanmışlara taşınmıştır.


RE: Klasördeki Resmin Dosya Yolunu Alma Ve Düşey Ara Vba İle - Mehmet Emin Alkan - 31/05/2021

Sayın feraz bey
Teşekkürler. Konu çözüme kavuşturulmuştur.