çalışma sayfasına kod aynı ise resim ekleme

[netvolxxx]

merhaba aşağıda yazan kodda bi olayı yapamadım user form da textbox ile arattırma yaptığımda kaydet dediğimde a hücresine adını yazıp b hücresine resim ekliyor bu olayı c hücresine adını yazdırıp b hücresine resim ekleyemedim hep bi sağ tarafa ekleme yapıyor.

bu işlemi nasıl yapıcam ustadların yardımına ihtiyacım var kodda değiştirmem gereken yer neresi...

sayfa 1 yazan kodlar

Private Sub Worksheet_Change(ByVal Target As Range)
Target.RowHeight = 70
Columns("B:B").ColumnWidth = 14
If Intersect(Target, [c2:c65536]) Is Nothing Then Exit Sub
yatay = 1
dikey = 0
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
deg1 = 0
hucre = ActiveWindow.RangeSelection.Address(False, False)
For i = 3 To Len(hucre)
If Mid(hucre, i, 3) = ":" Then
deg1 = 1
Exit For
Exit Sub
End If
Next
If deg1 = 0 Then
Adres = Worksheets(ActiveSheet.Name).Cells(Target.Row + dikey, Target.Column + yatay).Address
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If yer = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture
ReDim byfika$(50)
byfika$(1) = "bmp": byfika$(2) = "jpg"
byfika$(3) = "gif": byfika$(4) = "png"
For j = 1 To 4
If CreateObject("Scripting.FileSystemObject").FileExists(ThisWorkbook.Path & "\Resimler\" & Target.Value & "." & byfika(j)) = True Then
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\Resimler\" & Target.Value & "." & byfika(j)).Select
Selection.Top = Val(Target.Offset(dikey, yatay).Top + 4)
Selection.Left = Val(Target.Offset(dikey, yatay).Left + 4)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Val(Target.Offset(dikey, yatay).Height - 6)
Selection.ShapeRange.Width = Val(Target.Offset(dikey, yatay).Width - 6)
Cells(Target.Row + 1, Target.Column).Select
Exit For
End If
Next
End If

End Sub


userform da yazan kodlar


Private Sub CommandButton1_Click()
sat = Cells(Rows.Count, 1).End(1).Row + 1
Cells(sat, 3) = TextBox1.Value
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub Image1_Click()

End Sub

Private Sub UserForm_Click()

End Sub
Private Sub TextBox1_Change()
resimYol = ThisWorkbook.Path & "\Resimler\"
resimler = Dir(resimYol & "*.*")
resim = 0
While resimler <> ""
DoEvents
resimlerAd = Mid(resimler, 1, Len(resimler) - 4)
If resimlerAd = Me.TextBox1.Text Then
Me.Image1.Picture = LoadPicture(resimYol & resimler)
resim = 1
End If
resimler = Dir
Wend
If resim = 0 Then Me.Image1.Picture = LoadPicture(resimYol & "RESİM YOK.jpg")
Image1.PictureSizeMode = fmPictureSizeModeZoom
End Sub

 

[netvolxxx]

mevcut dosya ekledim daha iyi anlaşılması için ustadların yardımına ihtiyacım var....

 

[netvolxxx]

form da resim klasör içinde jpg uzantılı dosya adını yazınca geliyor 1234.jpg olarak 2 saatimi aldı daha hala bulamadım resim sol hücreye eklemeyi yardımlarınızı bekliyorum ustadlar.

 

[muygun]

Merhaba;
Eki deneyin (sizin kodlarınızı değiştirdim)
İyi çalışmalar.

 

[netvolxxx]

Merhaba;
Eki deneyin (sizin kodlarınızı değiştirdim)
İyi çalışmalar.

denedim resim sağ tarafa geliyor hocam fakat iki tane olay vardı onlar iptal olmuş birincisi resimle beraber resim yok.jpg de ekleniyor.ikincisi resim adı eklenen silince resimde siliniyordu.üçüncü olan resim adı rakam değilde yazı ile olunca ekleme yapmıyor

 

[netvolxxx]

hocam ayrıca şu olay da var onu nasıl yaparım b alanında birleştirilmiş hücreye resim ekleme hücre içine sığdırma olayı

 

[netvolxxx]

muygun ustad yaptığı uygulamadaki hataları giderilcek arkadaş varmı..

 

[netvolxxx]

Merhaba;
Eki deneyin (sizin kodlarınızı değiştirdim)
İyi çalışmalar.
[/QUO

Merhaba ustad silme delete işin çözdüm birleştirme ok de sadece şu bitane ekliyor her seferinde yeni bir şey yazıp kaydet dediğimde ekleme yapmıyor...

 

[muygun]

Merhaba;
Resimleriniz rakam mı?
Hem sayfada hemde userformda işlem mi yapıyorsunuz?

İlk yönlendirmenize istinaden oluşturduğum kodlarla ;
(Dosyada userformun kod kısmındaki)

Private Sub TextBox1_Change()
Makrosu ile Image1'e varsa resim alır.

Private Sub kaydet_butonu_Click()
Makrosu ile TextBox1'e yazılan rakamı C sütununda arar. Varsa üzerine yoksa en son boş satıra yazar.
sonra Call sayfaya_resim_getir satırı ile Sub sayfaya_resim_getir() makrosuna gider.

Sub sayfaya_resim_getir()
Makrosu ile Sayfadaki tüm resimler silinerek yenilenir. C sütunundaki resim adı no'suna göre resim varsa resim gelir. Yoksa Resşm Yok resmi gelir.

İşlemleri yapılıyor.
Bunun dışında yazdıklarınızdan bir anlam çıkaramadım. (Yada isteğinizi ben anlamadım)
İyi çalışmalar.

 

[netvolxxx]

Merhaba;
Resimleriniz rakam mı?
Hem sayfada hemde userformda işlem mi yapıyorsunuz?

İlk yönlendirmenize istinaden oluşturduğum kodlarla ;
(Dosyada userformun kod kısmındaki)

Private Sub TextBox1_Change()
Makrosu ile Image1'e varsa resim alır.

Private Sub kaydet_butonu_Click()
Makrosu ile TextBox1'e yazılan rakamı C sütununda arar. Varsa üzerine yoksa en son boş satıra yazar.
sonra Call sayfaya_resim_getir satırı ile Sub sayfaya_resim_getir() makrosuna gider.

Sub sayfaya_resim_getir()
Makrosu ile Sayfadaki tüm resimler silinerek yenilenir. C sütunundaki resim adı no'suna göre resim varsa resim gelir. Yoksa Resşm Yok resmi gelir.

İşlemleri yapılıyor.
Bunun dışında yazdıklarınızdan bir anlam çıkaramadım. (Yada isteğinizi ben anlamadım)
İyi çalışmalar.

merhaba daha önceki yazdığım mesajdaki sorunları çözdüm ustad sadece şunu yapamadım ilk mevcut sorumda da yoktu aynı yapıda birleştirilmiş hücreye resim ekleme olayı otamatik sığdırma. b alanında 4 satır birleştirilmiş hücre var b2-b5 birleştirilmiş olsun c2 de ürün adı bunu yapamadım sadece..

 

[muygun]

Birleştirme 4 lü şekilde mi devam ediyor?
Örnek dosya ekleyin.

 

[netvolxxx]

Birleştirme 4 lü şekilde mi devam ediyor?
Örnek dosya ekleyin.

evet dörtlü şekilde devam ediyor sürekli

 

[muygun]

Ok.
Biraz yoğunum. (Müsait olunca bakarım.)

 

[netvolxxx]

Ok.
Biraz yoğunum. (Müsait olunca bakarım.)

tamamdır ustad.
örnek dosya şablonu ekledim.

 

[muygun]

Merhaba;
Eki tekrar test edin.
İyi çalışmalar.

 

[netvolxxx]

Merhaba;
Eki tekrar test edin.
İyi çalışmalar.

ustad allah razı olsun sağol teşekürrr ederim istediğim buydu...

 

[netvolxxx]

Merhaba;
Eki tekrar test edin.
İyi çalışmalar.

ustad şimdi bir şey fark ettim mevcut resim boyutları yakın olduğu için anlayamamıştım biraz resim çözünürlüğü buyuk ekleyince birleştirilmiş hücreye içine eklemiyor taşıyor

 

[muygun]

Merhaba;
Ben böyle bir sorun göremedim.
NOT: Resimlerin .jpg uzantılı olması gerekiyor.

 

[netvolxxx]

Merhaba;
Ben böyle bir sorun göremedim.
NOT: Resimlerin .jpg uzantılı olması gerekiyor.

USTAD jpg olan bitane 1024x600 çöznürlük olsun ekleyince birleşen hücrenin dışına taşıyor...

 

[muygun]

Dosyaya resmi ekleyin. Taştığı şekliyle dosyayı ve ayrıca resmi buraya ekleyin.