Excelde resim ekleme

nikomedian · 25 Ağustos 2008

Merhaba , M sütunundaki Kod numaraları eklemek istediğim resimlerinin adının bir kısmını oluşturmaktadır. Bellirttiğim konumdan bu dosyayı yine kod yazan yerlerin 3 satır altındaki hücrelere yerleştirmek istiyorum.
Örnek:
Kod: 320911092C562N olması gereken dosya adı: 1092C562N yani sondan 9 karakteri. Yardımcı olabilrseniz çok sevinirim.

nikomedian · 25 Ağustos 2008

Kodu bu şekilde aldım ama bir sorun var...

Sub Resim_Ekle()
On Error Resume Next
Dim i, y, u As Integer
Dim k As String
Sheets("katalog").Select

For u = 1 To 7000
i = u + 3
y = i + 13
k = Right(Cells(u, 1), 9)
InsertPictureInRange "C:\resimler\" & k & ".TIF", _
Range("M" & i, "M" & y)
u = u + 19
Next u
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
On Error Resume Next
Sheets("katalog").Select
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

Ferhat Pazarçevirdi · 25 Ağustos 2008

Aşağıdaki makroyu bir butona atayınız ve çalıştırınız.

NOT :"Jpg" dosyalar için test edilmiştir. "Tif" uzantılı resim dosyalarında da, bir problem çıkaracağını sanmıyorum.

Kod:

Option Explicit
Const pth As String = "C:\resimler\"
Sub ResimEkle()
    Dim i As Integer
    Dim rnG As Range
    Dim reS As Picture
 
    With Sheets("katalog")
 
        For i = 1 To .Cells(65536, "M").End(xlUp).Row Step 19
            If Len(Dir(pth & Right(.Cells(i, "M"), 9) & ".tif", vbNormal)) > 0 Then
                .Cells(i + 3, "M") = Empty
                Set rnG = .Range(.Cells(i + 3, "M"), .Cells(i + 16, "M"))
 
                For Each reS In .Pictures
                    If Not Intersect(rnG, .Range(reS.TopLeftCell.Address & ":" & reS.BottomRightCell.Address)) Is Nothing Then
                       reS.Delete
                    End If
                Next
 
                Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
                With reS
                    .Top = rnG.Top
                    .Left = rnG.Left
                    .Width = rnG.Width
                    .Height = rnG.Height
                End With
            Else
                .Cells(i + 3, "M") = Chr(34) & pth & Chr(34) & " dizininde; ilişkili resim bulunamadı"
            End If
        Next i
 
    End With
 
    Set rnG = Nothing
    Set reS = Nothing
End Sub

nikomedian · 25 Ağustos 2008

Hocam çok sağolun sorunsuz çalışıyor, benim kodda nedense klasörün içinde olduğu halde almıyordu, bu kusursuz.

tahsinanarat · 25 Ağustos 2008

sn. nikomedian çalışan dosyayı eklermisiniz, ben çalıştıramadım, teşekkürler

nikomedian · 26 Ağustos 2008

Sn, tahsinanarat, dosyayı zaten ekte verdim.

tahsinanarat · 26 Ağustos 2008

Bende; "d:\foto\" dizininde; ilişkili resim bulunamadı; hatası veriyor, kodlarda adres yolunu ve resim isimlerini değiştirdim. olmadı, neyse beceremedik. Kolay gelsin.

nikomedian · 26 Ağustos 2008

tahsinanarat' Alıntı:
Bende; "d:\foto\" dizininde; ilişkili resim bulunamadı; hatası veriyor, kodlarda adres yolunu ve resim isimlerini değiştirdim. olmadı, neyse beceremedik. Kolay gelsin.

Hocam bu kodlamada, dosya tipi .tif oalrak yazıldı sizinki, jpg olabilir buna dikkat edin. Ayrıca bu kodlamada, ürün kodunun son 9 hanesine bakıyor, ve resim ismini ona göre belirliyor, bu kısımlara dikkat ettiniz mi?

tahsinanarat · 26 Ağustos 2008

Ferhat Pazarçevirdi' Alıntı:
Aşağıdaki makroyu bir butona atayınız ve çalıştırınız.

NOT :"Jpg" dosyalar için test edilmiştir. "Tif" uzantılı resim dosyalarında da, bir problem çıkaracağını sanmıyorum.

evet ben jpg resimlere uygulamaya çalışmıştım. tif uzantılı resimlerde oldu, ilginize çok teşekkür ederim.

Mr.NoBody · 26 Ağustos 2008

Bende teşekkür ederim. Aradığım bir kodu sayenizde buldum.

nikomedian · 26 Ağustos 2008

Benim bir sorunum daha var, ürün kodu 14 karakter, resimlerin isimleride 9 karakter yalnız şöyle bir sorun var. Ürün kodu: 320837OV8B4200, bir ürünün resmi 6OV8B4200 diye kayıtlı, yani 6. karakteri 7 olan bir grubun resimleri 6 ile başlıyor. hücre parçalama falan denedim ama işin içinden çıkamadım, yardımcı olabilir misiniz?

Ferhat Pazarçevirdi · 26 Ağustos 2008

Peki 6.Karakteri "6" olanlar nasıl oluyor? "6" olanlarla "7" olanların resimleri karışmıyor mu? Burada kaçırdığınız bir nokta var gibi ama ...

Aşağıdaki kodu deneyin. Değişiklik, kırmızı ile gösterilmiştir.

Kod:

Option Explicit
Const pth As String = "C:\resimler\"
Sub ResimEkle()
    Dim i As Integer
    Dim rnG As Range
    Dim reS As Picture
 
    With Sheets("katalog")
 
        For i = 1 To .Cells(65536, "M").End(xlUp).Row Step 19
            If Len(Dir(pth & Right(.Cells(i, "M"), 9) & ".tif", vbNormal)) > 0 Then
                .Cells(i + 3, "M") = Empty
                Set rnG = .Range(.Cells(i + 3, "M"), .Cells(i + 16, "M"))
 
                For Each reS In .Pictures
                    If Not Intersect(rnG, .Range(reS.TopLeftCell.Address & ":" & reS.BottomRightCell.Address)) Is Nothing Then
                       reS.Delete
                    End If
                Next
 
[COLOR=red]                If Mid(.Cells(i, "M"), 6, 1) = 7 Then
                    Set reS = .Pictures.Insert(pth & "6" & Right(.Cells(i, "M"), 8) & ".tif")
                Else
                    Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
                End If
[/COLOR]                
                With reS
                    .Top = rnG.Top
                    .Left = rnG.Left
                    .Width = rnG.Width
                    .Height = rnG.Height
                End With
            Else
                .Cells(i + 3, "M") = Chr(34) & pth & Chr(34) & " dizininde; ilişkili resim bulunamadı"
            End If
        Next i
 
    End With
 
    Set rnG = Nothing
    Set reS = Nothing
End Sub

nikomedian · 26 Ağustos 2008

teşekkür ederim kodu yarın deneyeceğim, hayır o kısım normal ilk 5 karakterde yıl sezon bilgileri yer alıyor 6. karakterden itibaren ürün bilgileri geliyor. çok saolun

nikomedian · 27 Ağustos 2008

hocam sizin koda ek olarak 6 'yı 8'e, 7'yide 6'ay dönüştürmesi için elseif ekledim. Ama çalışmadı yardımcı olabilir misiniz ?

Option Explicit
Const pth As String = "C:\resimler\"
Sub ResimEkle()
Dim i As Integer
Dim rnG As Range
Dim reS As Picture

With Sheets("katalog")

For i = 1 To .Cells(65536, "M").End(xlUp).Row Step 19
If Len(Dir(pth & Right(.Cells(i, "M"), 9) & ".tif", vbNormal)) > 0 Then
.Cells(i + 3, "M") = Empty
Set rnG = .Range(.Cells(i + 3, "M"), .Cells(i + 16, "M"))

For Each reS In .Pictures
If Not Intersect(rnG, .Range(reS.TopLeftCell.Address & ":" & reS.BottomRightCell.Address)) Is Nothing Then
reS.Delete
End If
Next

If Mid(.Cells(i, "M"), 6, 1) = 6 Then
Set reS = .Pictures.Insert(pth & "8" & Right(.Cells(i, "M"), 8) & ".tif")
ElseIf Mid(.Cells(i, "M"), 6, 1) = 7 Then
Set reS = .Pictures.Insert(pth & "6" & Right(.Cells(i, "M"), 8) & ".tif")

Else
Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
End If

With reS
.Top = rnG.Top
.Left = rnG.Left
.Width = rnG.Width
.Height = rnG.Height
End With
Else
.Cells(i + 3, "M") = Chr(34) & pth & Chr(34) & " dizininde; ilişkili resim bulunamadı"
End If
Next i

End With

Set rnG = Nothing
Set reS = Nothing
End Sub

Ferhat Pazarçevirdi · 27 Ağustos 2008

If-ElseIf-End If bloğunu kodlarınızdan kaldırın ve onların yerine aşağıdakini yapıştırın

Kod:

Select Case Mid(.Cells(i, "M"), 6, 1)

    Case "6": Set reS = .Pictures.Insert(pth & "8" & Right(.Cells(i, "M"), 8) & ".tif")

    Case "7": Set reS = .Pictures.Insert(pth & "6" & Right(.Cells(i, "M"), 8) & ".tif")

    Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")

End Select

nikomedian · 27 Ağustos 2008

Dediğiniz gibi nextten sonrasına yapıştırdım ama

Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")

satırında else without if hatası veriyor.

reS.Delete
End If
Next

Select Case Mid(.Cells(i, "M"), 6, 1)
Case "6": Set reS = .Pictures.Insert(pth & "8" & Right(.Cells(i, "M"), 8) & ".tif")
Case "7": Set reS = .Pictures.Insert(pth & "6" & Right(.Cells(i, "M"), 8) & ".tif")
Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
End Select

With reS
.Top = rnG.Top

Ferhat Pazarçevirdi · 27 Ağustos 2008

Bem kodu eksik yazmışım ...

Else ... diye hata veren satırın başına Case yazın. Yani ;

Case Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")

nikomedian · 27 Ağustos 2008

düzelttim kod çalıştı yalnzı yine bulamadı resmi; örnek olarak
320917OP8B6581 ürün koduna sahip ürünün, resmi 6OP8B6581.tif olacak, bu resim ilgili dosyanın içinde var ama çekmiyor malesef.

Ferhat Pazarçevirdi · 27 Ağustos 2008

Eğer resim isimleri doğruysa, bulması gerekiyor.

Siz, hücredeki "O" harfinin, tif resim dosyasının isminde de "O" harfi olup olmadığın kontrol ediniz. Belki de, "O" harfi yerine "0" rakamı kullanılmıştır.

nikomedian · 27 Ağustos 2008

Yok hocam 7'le başlayanların hibiri çıkmamış, kodlar bu şekildeyse ben diğer resimleri bi kontrol edeyim.

Option Explicit
Const pth As String = "C:\resimler\"
Sub ResimEkle()
Dim i As Integer
Dim rnG As Range
Dim reS As Picture

With Sheets("katalog")

For i = 1 To .Cells(65536, "M").End(xlUp).Row Step 19
If Len(Dir(pth & Right(.Cells(i, "M"), 9) & ".tif", vbNormal)) > 0 Then
.Cells(i + 3, "M") = Empty
Set rnG = .Range(.Cells(i + 3, "M"), .Cells(i + 16, "M"))

For Each reS In .Pictures
If Not Intersect(rnG, .Range(reS.TopLeftCell.Address & ":" & reS.BottomRightCell.Address)) Is Nothing Then
reS.Delete
End If
Next

Select Case Mid(.Cells(i, "M"), 6, 1)
Case "6": Set reS = .Pictures.Insert(pth & "8" & Right(.Cells(i, "M"), 8) & ".tif")
Case "7": Set reS = .Pictures.Insert(pth & "6" & Right(.Cells(i, "M"), 8) & ".tif")
Case Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
End Select

With reS
.Top = rnG.Top
.Left = rnG.Left
.Width = rnG.Width
.Height = rnG.Height
End With
Else
.Cells(i + 3, "M") = Chr(34) & pth & Chr(34) & " dizininde; ilişkili resim bulunamadı"
End If
Next i

End With

Set rnG = Nothing
Set reS = Nothing
End Sub

Excelde resim ekleme

nikomedian

nikomedian

Ferhat Pazarçevirdi

Özel Üye

nikomedian

tahsinanarat

nikomedian

tahsinanarat

nikomedian

tahsinanarat

Mr.NoBody

Misafir

nikomedian

Ferhat Pazarçevirdi

Özel Üye

nikomedian

nikomedian

Ferhat Pazarçevirdi

Özel Üye

nikomedian

Ferhat Pazarçevirdi

Özel Üye

nikomedian

Ferhat Pazarçevirdi

Özel Üye

nikomedian