• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excelde resim ekleme

N

nikomedian

Katılım
14 Ağustos 2008
Mesajlar
82
Excel Vers. ve Dili
2003 - english
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.
 
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
Genişletmek için tıkla ...
 
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
 
Son düzenleme:
Hocam &#231;ok sa&#287;olun sorunsuz &#231;al&#305;&#351;&#305;yor, benim kodda nedense klas&#246;r&#252;n i&#231;inde oldu&#287;u halde alm&#305;yordu, bu kusursuz.
 
sn. nikomedian &#231;al&#305;&#351;an dosyay&#305; eklermisiniz, ben &#231;al&#305;&#351;t&#305;ramad&#305;m, te&#351;ekk&#252;rler
 
Bende; "d:\foto\" dizininde; ili&#351;kili resim bulunamad&#305;; hatas&#305; veriyor, kodlarda adres yolunu ve resim isimlerini de&#287;i&#351;tirdim. olmad&#305;, neyse beceremedik. Kolay gelsin.
 
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.
Genişletmek için tıkla ...

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?
 
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.
Genişletmek için tıkla ...
 
Bende te&#351;ekk&#252;r ederim. Arad&#305;&#287;&#305;m bir kodu sayenizde buldum.
 
Benim bir sorunum daha var, &#252;r&#252;n kodu 14 karakter, resimlerin isimleride 9 karakter yaln&#305;z &#351;&#246;yle bir sorun var. &#220;r&#252;n kodu: 320837OV8B4200, bir &#252;r&#252;n&#252;n resmi 6OV8B4200 diye kay&#305;tl&#305;, yani 6. karakteri 7 olan bir grubun resimleri 6 ile ba&#351;l&#305;yor. h&#252;cre par&#231;alama falan denedim ama i&#351;in i&#231;inden &#231;&#305;kamad&#305;m, yard&#305;mc&#305; olabilir misiniz?
 
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
 
te&#351;ekk&#252;r ederim kodu yar&#305;n deneyece&#287;im, hay&#305;r o k&#305;s&#305;m normal ilk 5 karakterde y&#305;l sezon bilgileri yer al&#305;yor 6. karakterden itibaren &#252;r&#252;n bilgileri geliyor. &#231;ok saolun
 
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
Genişletmek için tıkla ...
 
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
 
Dedi&#287;iniz gibi nextten sonras&#305;na yap&#305;&#351;t&#305;rd&#305;m ama
Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
Genişletmek için tıkla ...
sat&#305;r&#305;nda else without if hatas&#305; 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
Genişletmek için tıkla ...
 
Bem kodu eksik yazm&#305;&#351;&#305;m ...

Else ... diye hata veren sat&#305;r&#305;n ba&#351;&#305;na Case yaz&#305;n. Yani ;

Case Else: Set reS = .Pictures.Insert(pth & Right(.Cells(i, "M"), 9) & ".tif")
 
d&#252;zelttim kod &#231;al&#305;&#351;t&#305; yalnz&#305; yine bulamad&#305; resmi; &#246;rnek olarak
320917OP8B6581 &#252;r&#252;n koduna sahip &#252;r&#252;n&#252;n, resmi 6OP8B6581.tif olacak, bu resim ilgili dosyan&#305;n i&#231;inde var ama &#231;ekmiyor malesef.
 
E&#287;er resim isimleri do&#287;ruysa, bulmas&#305; gerekiyor.

Siz, h&#252;credeki "O" harfinin, tif resim dosyas&#305;n&#305;n isminde de "O" harfi olup olmad&#305;&#287;&#305;n kontrol ediniz. Belki de, "O" harfi yerine "0" rakam&#305; kullan&#305;lm&#305;&#351;t&#305;r.
 
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
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst