• DİKKAT

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

Kodu Revize Etmek İçin Yardım:Sayfaya Resim Atma

  • Konbuyu başlatan Konbuyu başlatan BedriA
  • Başlangıç tarihi Başlangıç tarihi
B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Aşağıdaki kod ile seçime göre sayfamın E8 ve H8 hücrelerine resim atıyorum.
Kod şöyle bir eksikle çalışıyor: İlk resim istediğim gibi E8'e yerleşiyor. Ancak ikinci resmi eklediğimde H8 yerine, H9'a yerleşiyor. Sanıyorum şu kısımda bir değişiklik veya ekleme gerekiyor:

Kod: 
sat = sat + 1
sut = ab
If sat < 8 Then sat = 8

Kodun tamamı aşağıda:

Kod: 
Private Sub CommandButton28_Click()

If test20.OptionButton6 = False And test20.OptionButton8 = False Then
MsgBox "Sorunun aktarılacağı sütunu seçmediniz.", vbInformation, "      Uyarı"
Exit Sub
End If

If test20.OptionButton6 = True Then
sayfa = "test20"
ab = 5
xy = "E"
mn = "E65536"


ElseIf test20.OptionButton8 = True Then
sayfa = "test20"
ab = 8
xy = "H"
mn = "H65536"

End If



Son_Dolu_Satir = Sheets(sayfa).Range(mn).End(3).Row
Dim s1
Dim sat
sat = 0
Set s1 = Sheets(sayfa)

Dim SH As Shape
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
sat = SH.TopLeftCell.Row
End If
Next SH


sat = sat + 1
sut = ab
If sat < 8 Then sat = 8


If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1

s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
If SH.TopLeftCell.Row = sat Then
s1.Shapes(SH.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(SH.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4
s1.Shapes(SH.Name).OLEFormat.Object.Name = SH.BottomRightCell.Row
End If
End If
Next SH

Son_Dolu_Satir = s1.Range(mn).End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range(xy & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"



Controls("Image1").Picture = LoadPicture("")
CommandButton25.Locked = True


End Sub
 
surularınızı sorarken mutla örnek dosyanızın küçük bir bölümünü koyun bazen kodlardan bir şey anlaşılmıyor.

bu kodu bir dene bakalım

Kod: 
Private Sub CommandButton28_Click()

If test20.OptionButton6 = False And test20.OptionButton8 = False Then
MsgBox "Sorunun aktarılacağı sütunu seçmediniz.", vbInformation, "      Uyarı"
Exit Sub
End If


If test20.OptionButton6 = True Then
sayfa = "test20"
xy = "E"
sut = 5
ElseIf test20.OptionButton8 = True Then
sayfa = "test20"
xy = "H"
sut = 8
End If


Son_Dolu_Satir = Sheets(sayfa).Cells(Rows.Count, xy).End(3).Row
Dim s1
Dim sat, sat1
sat = 0
sat1 = 0
Set s1 = Sheets(sayfa)

Dim SH As Shape
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then

If SH.TopLeftCell.Column = 5 Then
sat = sat + 1
End If

If SH.TopLeftCell.Column = 8 Then
sat1 = sat1 + 1
End If

End If
Next SH


If sat = sat1 Then
sat = sat + 1
Else
sat = sat1
End If

If sat < 8 Then sat = 8

If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1

s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
If SH.TopLeftCell.Row = sat Then
s1.Shapes(SH.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(SH.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4
s1.Shapes(SH.Name).OLEFormat.Object.Name = SH.BottomRightCell.Row
End If
End If
Next SH

Son_Dolu_Satir = s1.Range(mn).End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range(xy & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"



Controls("Image1").Picture = LoadPicture("")
CommandButton25.Locked = True
 
veya böyle

Kod: 
Private Sub CommandButton28_Click()

If test20.OptionButton6 = False And test20.OptionButton8 = False Then
MsgBox "Sorunun aktarılacağı sütunu seçmediniz.", vbInformation, "      Uyarı"
Exit Sub
End If


If test20.OptionButton6 = True Then
sayfa = "test20"
xy = "E"
sut = 5
ElseIf test20.OptionButton8 = True Then
sayfa = "test20"
xy = "H"
sut = 8
End If


Son_Dolu_Satir = Sheets(sayfa).Cells(Rows.Count, xy).End(3).Row
Dim s1
Dim sat, sat1, sat2
sat = 0
sat1 = 7
sat2 = 7
Set s1 = Sheets(sayfa)

Dim SH As Shape
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then

If SH.TopLeftCell.Column = 5 Then
sat1 = sat1 + 1
End If

If SH.TopLeftCell.Column = 8 Then
sat2 = sat2 + 1
End If

End If
Next SH


If test20.OptionButton6 = True Then
sat = sat1 + 1
ElseIf test20.OptionButton8 = True Then
sat = sat2 + 1
End If


If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1

s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
If SH.TopLeftCell.Row = sat Then
s1.Shapes(SH.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(SH.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4
s1.Shapes(SH.Name).OLEFormat.Object.Name = SH.BottomRightCell.Row
End If
End If
Next SH

Son_Dolu_Satir = s1.Range(mn).End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range(xy & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"



Controls("Image1").Picture = LoadPicture("")
CommandButton25.Locked = True
 
Halit Hocam,

Kodun içinde resimleri numaralara göre yerleştiren bir kısım var, o kısım E'ye atılana da, H'ye atılana da aynı numarayı veriyor. Dolayısıyla ikinci resmi atınca, ikisi de tek hücreye biniyor. Atılan her resme farklı numara verilebilse sorun çözülebilecek sanırım.

Bu arada; çalıştığım dosya öyle kalabalık ki, nasıl örnek dosya yapacağımı şaşırıyorum.
 
Son düzenleme:
o zaman resimleri adını değiştirmek gerekiyor
E sütunundakilere E1,E2,E3..... diye gidecek H sütünundakilerde H1,H2,H3 diye gidecek.


Kod: 
Private Sub CommandButton28_Click()

If test20.OptionButton6 = False And test20.OptionButton8 = False Then
MsgBox "Sorunun aktarılacağı sütunu seçmediniz.", vbInformation, "      Uyarı"
Exit Sub
End If


If test20.OptionButton6 = True Then
sayfa = "test20"
xy = "E"
sut = 5
ElseIf test20.OptionButton8 = True Then
sayfa = "test20"
xy = "H"
sut = 8
End If


Son_Dolu_Satir = Sheets(sayfa).Cells(Rows.Count, xy).End(3).Row
Dim s1
Dim sat, sat1, sat2
sat = 0
sat1 = 7
sat2 = 7
Set s1 = Sheets(sayfa)

Dim SH As Shape
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then

If SH.TopLeftCell.Column = 5 Then
sat1 = sat1 + 1
End If

If SH.TopLeftCell.Column = 8 Then
sat2 = sat2 + 1
End If

End If
Next SH


If test20.OptionButton6 = True Then
sat = sat1 + 1

ElseIf test20.OptionButton8 = True Then
sat = sat2 + 1
End If


If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1

s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
If SH.TopLeftCell.Row = sat Then
s1.Shapes(SH.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(SH.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4

s1.Shapes(SH.Name).OLEFormat.Object.Name = [COLOR="Red"]xy &[/COLOR] SH.BottomRightCell.Row
End If
End If
Next SH

Son_Dolu_Satir = s1.Range(mn).End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range(xy & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"


Controls("Image1").Picture = LoadPicture("")
CommandButton25.Locked = True
End Sub
 
Halit Hocam,

İkincisini ekleyince, ikisini de H8 yaptı.
İlkini eklediğimde numarası E8 di oysa.
 
kod resimlerin doğru sutununnu buluyormu onu bilmek lazım

Kod: 
If [COLOR="red"]SH.TopLeftCell.Column[/COLOR] = 5 Then
sat1 = sat1 + 1
End If

If [COLOR="Red"]SH.TopLeftCell.Column [/COLOR]= 8 Then
sat2 = sat2 + 1
End If

yukarıdaki kırmızı yerleri
bununla bir değiştir.

Kod: 
SH.BottomRightCell.Column
 
Olmadı Halit Hocam.
İkincisini atınca yine ikisi de H8 oluyor.
Sizi de çok uğraştırdım ama galiba soruları resim olarak atmaktan vazgeçeceğim galiba.
Bu da programın kullanımını büyük ölçüde sınırlandıracak. Şöyle ki: Görsel içerikli sorular kullanılamayacak, salt metin içerikli soruları kabul edecek sistem.

Ya da şu bir çözüm olur mu? E ve H sütunları için ayrı butonlar yapmak?
1. Sütuna Aktar, 2. Sütuna Aktar butonları... Bununla yine aynı sorunla karşılaşır mıyız acaba?
 
Son düzenleme:
Halit Hocam,

İki buton yaptım. E sütunu için olan buton sorunsuz çalışıyor.
İkincisi diğer kod ile aynı yapıda olup kırmızı kısımda hata veriyor.

Kod: 
Private Sub CommandButton29_Click()
If test20.OptionButton6 = False And test20.OptionButton8 = False Then
MsgBox "Sorunun aktarılacağı sütunu seçmediniz.", vbInformation, "      Uyarı"
Exit Sub
End If


If test20.OptionButton6 = True Then
sayfa = "test20"
xy = "H"
sut = 8

End If


[COLOR="Red"]Son_Dolu_Satir = Sheets(sayfa).Cells(Rows.Count, xy).End(3).Row[/COLOR]
Dim s1
Dim sat, sat1, sat2
sat = 0
sat1 = 7
sat2 = 7
Set s1 = Sheets(sayfa)

Dim SH As Shape
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then

If SH.TopLeftCell.Column = 8 Then
sat2 = sat2 + 1
End If



End If
Next SH


If test20.OptionButton8 = True Then
sat = sat2 + 1


If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1

s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
If SH.TopLeftCell.Row = sat Then
s1.Shapes(SH.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(SH.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4

s1.Shapes(SH.Name).OLEFormat.Object.Name = xy & SH.BottomRightCell.Row
End If
End If
Next SH

Son_Dolu_Satir = s1.Range("H6536").End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range(xy & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"


Controls("Image1").Picture = LoadPicture("")
End If
End Sub


Diğer butona ait kod:

Kod: 
Private Sub CommandButton28_Click()

If test20.OptionButton6 = False And test20.OptionButton8 = False Then
MsgBox "Sorunun aktarılacağı sütunu seçmediniz.", vbInformation, "      Uyarı"
Exit Sub
End If


If test20.OptionButton6 = True Then
sayfa = "test20"
xy = "E"
sut = 5

End If


Son_Dolu_Satir = Sheets(sayfa).Cells(Rows.Count, xy).End(3).Row
Dim s1
Dim sat, sat1, sat2
sat = 0
sat1 = 7
sat2 = 7
Set s1 = Sheets(sayfa)

Dim SH As Shape
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then

If SH.TopLeftCell.Column = 5 Then
sat1 = sat1 + 1
End If



End If
Next SH


If test20.OptionButton6 = True Then
sat = sat1 + 1


If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1

s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)
For Each SH In s1.Shapes
If TypeName(SH.OLEFormat.Object) = "Picture" Then
If SH.TopLeftCell.Row = sat Then
s1.Shapes(SH.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(SH.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(SH.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4

s1.Shapes(SH.Name).OLEFormat.Object.Name = xy & SH.BottomRightCell.Row
End If
End If
Next SH

Son_Dolu_Satir = s1.Range("E6536").End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range(xy & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"


Controls("Image1").Picture = LoadPicture("")
End If
End Sub

Hatanın ekran görüntüsü ektedir.

2.png - 128 KB
 
Son düzenleme:
BedriA' Alıntı:
Halit Hocam,

İki buton yaptım. E sütunu için olan buton sorunsuz çalışıyor.
İkincisi diğer kod ile aynı yapıda olup kırmızı kısımda hata veriyor.
Genişletmek için tıkla ...

Bu hatayı verdiğinde Debug deyin ve sarı yazılı yerde,
(Sayfa) yazan yerin ve XY yazan yerin üzerine mouse ile gelin sarı kutu içinde değerlerini yazacaktır. Onları buraya yazar mısınız? Belki de bu konuma geldiğinde olması gereken değerleri almamışlardır.
 
Asri Hocam,

İlginize çok teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst