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
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.
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
Konu cevaplanmışlara taşınmıştır.
Sayın feraz bey
Teşekkürler. Konu çözüme kavuşturulmuştur.