• DİKKAT

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

[Çözüldü] Kodu Revize Etmek İçin Yardım

B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Arkadaşlar,

Aşağıdaki kod ile çalışma kitabımın 1. sayfasından, listbox1 click olayı ile userformuma çağırdığım resmi, aynı çalışma kitabımın "klasiksinav5a" sayfasına aktarmak istediğimde "Picture insert özelliği alınamıyor" hatası alıyorum.

Şu kod ile resmi sayfadan userforma çağırıyorum:

Kod: 
Private Sub ListBox1_Click()


Set s1 = Worksheets("sayfa1")
MsgBox "Resim eklendi.", vbInformation, "       Bilgi"

a = ListBox1.ListIndex + 2

Adres = s1.Cells(a, 1).Address
Dim Picture As Object
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

If yer = Adres Then
sut = Picture.BottomRightCell.Row

s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture

UserForm7.Image1.Picture = PastePicture
Unload Me
UserForm7.Show
Exit For
End If
End If

Next Picture


End Sub

Şu kod ile userform üzerindeki resmi başka bir sayfaya aktarmak istiyorum ancak hata veriyor.

Kodu revize edebilir misiniz rica etsem?

Kod: 
Private Sub CommandButton25_Click()
Sheets("klasiksinav5a").Pictures.Insert(resim_adi).Select
Selection.Top = Range("E8").Top: Selection.Left = Range("E8").Left
Selection.ShapeRange.LockAspectRatio = msoFalse: Selection.ShapeRange.Height = 150: Selection.ShapeRange.Width = 250
ActiveCell.Select
                                              
Sheets("klasiksinav5a").Select
End Sub
 
Son düzenleme:
Sayfaya yapıştırmak için kodu ListBox1_Click içine koy

Kod: 
Private Sub ListBox1_Click()


Set s1 = Worksheets("sayfa1")
MsgBox "Resim eklendi.", vbInformation, "       Bilgi"

a = ListBox1.ListIndex + 2

Adres = s1.Cells(a, 1).Address
Dim Picture As Object
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

If yer = Adres Then
sut = Picture.BottomRightCell.Row

s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture

UserForm7.Image1.Picture = PastePicture
[COLOR="Red"]Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Range("E8")[/COLOR]

Unload Me
UserForm7.Show
Exit For
End If
End If

Next Picture


End Sub


veya listeden seçtikten sonra

Kod: 
Private Sub CommandButton25_Click()
Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Range("E8")
End Sub
 
halit3' Alıntı:
Sayfaya yapıştırmak için kodu ListBox1_Click içine koy

Kod: 
Private Sub ListBox1_Click()


Set s1 = Worksheets("sayfa1")
MsgBox "Resim eklendi.", vbInformation, "       Bilgi"

a = ListBox1.ListIndex + 2

Adres = s1.Cells(a, 1).Address
Dim Picture As Object
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

If yer = Adres Then
sut = Picture.BottomRightCell.Row

s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture

UserForm7.Image1.Picture = PastePicture
[COLOR="Red"]Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Range("E8")[/COLOR]

Unload Me
UserForm7.Show
Exit For
End If
End If

Next Picture


End Sub


veya listeden seçtikten sonra

Kod: 
Private Sub CommandButton25_Click()
Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Range("E8")
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim Halit Hocam.
Elinize, zihninize sağlık.

Sevdiklerinizle iyi bir bayram geçirmeniz dileğiyle bayramınız kutlu olsun.
 
Halit Hocam,

Aşağıdaki kodu E8'den başlayarak seçilen resmi bir öncekinin altındaki hücreye (E9'a) atacak şekilde nasıl revize edebiliriz?

Selam ve saygılarımla.

Kod: 
Private Sub CommandButton25_Click()
Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Range("E8")
End Sub
 
Son düzenleme:
kod

Kod: 
Private Sub CommandButton25_Click()

son = Worksheets("klasiksinav5a").Cells(Rows.Count, "e").End(3).Row + 1
If son < 8 Then son = 8
Worksheets("klasiksinav5a").Cells(son, "e").Value = "'"
Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Cells(son, "e")

End Sub
 
halit3' Alıntı:
kod

Kod: 
Private Sub CommandButton25_Click()

son = Worksheets("klasiksinav5a").Cells(Rows.Count, "e").End(3).Row + 1
If son < 8 Then son = 8
Worksheets("klasiksinav5a").Cells(son, "e").Value = "'"
Worksheets("klasiksinav5a").Paste Destination:=Worksheets("klasiksinav5a").Cells(son, "e")

End Sub
Genişletmek için tıkla ...

Halit Hocam,

Resmi sayfaya atıyor ancak doğru hücreye atmıyor. Mesela E8'e gelmesi gereken resim çok daha aşağı gidiyor. Daha önce verdiğiniz aşağıdaki kodu, verdiğiniz kodun sonuna alınca tam olarak istediğim yere gidiyor.

Ancak ben Optionbutton seçimine göre resimleri istediğim sayfaya gönderiyorum. Böyle olunca hata veriyor. Hataya dair resim de ekte. Kullandığım kod aşağıdaki şekilde.

Kod: 
Private Sub CommandButton25_Click()
[COLOR="red"]'5alt-a [/COLOR]
If şablon.OptionButton1 = True Then
son = Worksheets("5alt-a").Cells(Rows.Count, "e").End(3).Row + 1
If son < 8 Then son = 8
Worksheets("5alt-a").Cells(son, "e").Value = "'"
Worksheets("5alt-a").Paste Destination:=Worksheets("5alt-a").Cells(son, "e")
End If

Dim Adres As Range
sut = 5
i = 7

Dim s1
Set s1 = Sheets("5alt-a")

Dim Picture As Object
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
i = i + 1
Adres1 = Range(Cells(i, sut), Cells(i, sut)).Address
Set Adres = Range(Adres1)
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

'If yer = Adres1 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(Picture.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4
s1.Shapes(Picture.Name).OLEFormat.Object.Name = Picture.BottomRightCell.Row
'End If
End If
Next Picture


[COLOR="Red"]'8alt-a[/COLOR]
If şablon.OptionButton3 = True Then
son = Worksheets("8alt-a").Cells(Rows.Count, "e").End(3).Row + 1
If son < 8 Then son = 8
Worksheets("8alt-a").Cells(son, "e").Value = "'"
Worksheets("8alt-a").Paste Destination:=Worksheets("8alt-a").Cells(son, "e")
End If

Dim Adres As Range
sut = 5
i = 7

Dim s1
Set s1 = Sheets("8alt-a")

Dim Picture As Object
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
i = i + 1
Adres1 = Range(Cells(i, sut), Cells(i, sut)).Address
Set Adres = Range(Adres1)
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

'If yer = Adres1 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(Picture.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4
s1.Shapes(Picture.Name).OLEFormat.Object.Name = Picture.BottomRightCell.Row
'End If
End If
Next Picture

End Sub
 

Ekli dosyalar

  • 1.jpg
    1.jpg
    375.2 KB · Görüntüleme: 3
kod:

Kod: 
Private Sub CommandButton27_Click()

Dim s1
Set s1 = Sheets("8alt-a")
sut = 5
sat = s1.Cells(Rows.Count, "e").End(3).Row + 1
If sat < 8 Then sat = 8
s1.Cells(sat, "e").Value = "'"
s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)

Dim SH As Shape
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

End Sub
 
halit3' Alıntı:
kod:

Kod: 
Private Sub CommandButton27_Click()

Dim s1
Set s1 = Sheets("8alt-a")
sut = 5
sat = s1.Cells(Rows.Count, "e").End(3).Row + 1
If sat < 8 Then sat = 8
s1.Cells(sat, "e").Value = "'"
s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)

Dim SH As Shape
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

End Sub
Genişletmek için tıkla ...


Örnek resimden de anlaşılacağı üzere bir hayli kalabalık bir çalışma. O yüzden dosya paylaşsam daha karmaşık olacak...

Şöyle izah edeyim kısaca:

6 tane sayfam var. Her sayfada sınav kağıtları için farklı bir dizayn var. Öğretmen istediği şablonu seçiyor, ona göre seçtiği resim (soru) sayfaya aktarılıyor. Kağıda aktarmak için tek bir buton var. Bu buton altı optionbuttondan birinin seçimine göre çalışacak.

"klasiksinav5a" sayfasını optionbutton2, "klasiksinav8a" sayfasını optionbutton4, "klasiksinav10a" sayfasını optionbutton6, "5alt-a" sayfasını optionbutton1, "8alt-a " sayfasını optionbutton3 ve "10alt-a" sayfasını optionbutton5 ile seçiyorum.

Son verdiğini kodu farklı bir butona atayınca çalışıyor ama bu butona diğer sayfalar için de kod atadığım zaman yine resimdeki hatayı alıyorum.

İlginiz için tekrar tekrar teşekkür ediyorum.
 
kod:

Kod: 
Private Sub CommandButton27_Click()


If şablon.OptionButton1 = True Then
sayfa = "[COLOR="red"]8alt-a[/COLOR]"
ElseIf şablon.OptionButton2 = True Then
sayfa = "[COLOR="red"]klasiksinav5aé[/COLOR]"
ElseIf şablon.OptionButton3 = True Then
sayfa = "[COLOR="red"]klasiksinav10a[/COLOR]"
End If



Dim s1
Set s1 = Sheets([COLOR="Red"]sayfa[/COLOR])
sut = 5
sat = s1.Cells(Rows.Count, "e").End(3).Row + 1
If sat < 8 Then sat = 8
s1.Cells(sat, "e").Value = "'"
s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)

Dim SH As Shape
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

End Sub
 
halit3' Alıntı:
kod:

Kod: 
Private Sub CommandButton27_Click()


If şablon.OptionButton1 = True Then
sayfa = "[COLOR="red"]8alt-a[/COLOR]"
ElseIf şablon.OptionButton2 = True Then
sayfa = "[COLOR="red"]klasiksinav5aé[/COLOR]"
ElseIf şablon.OptionButton3 = True Then
sayfa = "[COLOR="red"]klasiksinav10a[/COLOR]"
End If



Dim s1
Set s1 = Sheets([COLOR="Red"]sayfa[/COLOR])
sut = 5
sat = s1.Cells(Rows.Count, "e").End(3).Row + 1
If sat < 8 Then sat = 8
s1.Cells(sat, "e").Value = "'"
s1.Paste Destination:=s1.Cells(sat, sut)

Set Adres = s1.Range(s1.Range(s1.Cells(sat, sut), s1.Cells(sat, sut)).Address)

Dim SH As Shape
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

End Sub
Genişletmek için tıkla ...


Halit Hocam,

İstediğim sayfaya atıyor ama istediğim hücreye atamıyor.
Her sayfa için denedim, ilk resmi E8 yerine, E21'e atıyor, sonra 22, 23, ... şeklinde devam ediyor. Daha önce verdiğiniz aşağıdaki kodu hangi sayfa için bir butona atasam, resimleri yerli yerine taşıyor ama bu durumda 6 sayfa için 6 buton olması gerekiyor ki formda bu kadar buton için yer yok.

Sizi çok yordum, kusura bakmayın.

Selam ve saygılarımla.

Kod: 
Private Sub CommandButton26_Click()

Dim Adres As Range
sut = 5
i = 7

Dim s1
Set s1 = Sheets("5alt-a")

Dim Picture As Object
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
i = i + 1
Adres1 = Range(Cells(i, sut), Cells(i, sut)).Address
Set Adres = Range(Adres1)
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

'If yer = Adres1 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(Picture.Name).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4
s1.Shapes(Picture.Name).OLEFormat.Object.Name = Picture.BottomRightCell.Row
'End If
End If
Next Picture
End Sub
 
Son düzenleme:
userforma bir adet combobox nesnesi ekleyin

UserForm_Initialize olayına bunu ekle

Kod: 
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name <> "[COLOR="Red"]Sayfa1[/COLOR]" Then
If Sheets(i).Name <> "[COLOR="Red"]anasayfa[/COLOR]" Then
ComboBox1.AddItem Sheets(i).Name
End If
End If
Next
ComboBox1.Text = ComboBox1.List(0)

kırmızı yazılan sayfalar dışındakş sayfalar combobox nesnesine alınıyor sonra sayfaları bu nesneden seçip aşağıdaki kodu çalıştır.

Kod: 
Private Sub CommandButton28_Click()

Dim s1
Dim sat
sat = 0
Set s1 = Sheets(ComboBox1.Text)

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 = 5
If sat < 8 Then sat = 8

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

End Sub
 
Hocam,

Sayfa isimleri pek anlaşılır olmayacak Comboboxta.
5alt-a
8alt-a
10alt-a
klasiksinav5a
klasiksinav8a
klasiksinav10a gibi.

Örneğin 5alt-a = 5 Soru Alt Alta gibi görünse ama yine 5alt-a sayfasına yazdırsa.

Bu mümkün olur mu?
 
O zaman combobox dan vazgeçelim

Kod: 
Private Sub CommandButton28_Click()


If şablon.OptionButton1 = True Then
sayfa = "8alt-a"
ElseIf şablon.OptionButton2 = True Then
sayfa = "klasiksinav5aé"
ElseIf şablon.OptionButton3 = True Then
sayfa = "klasiksinav10a"
End If




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 = 5
If sat < 8 Then sat = 8

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

End Sub
 
halit3' Alıntı:
O zaman combobox dan vazgeçelim

Kod: 
Private Sub CommandButton28_Click()


If şablon.OptionButton1 = True Then
sayfa = "8alt-a"
ElseIf şablon.OptionButton2 = True Then
sayfa = "klasiksinav5aé"
ElseIf şablon.OptionButton3 = True Then
sayfa = "klasiksinav10a"
End If




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 = 5
If sat < 8 Then sat = 8

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

End Sub
Genişletmek için tıkla ...


Hocam harikasınız ya!
Çok ama çok teşekkür ederim.
Combobox yöntemi de çok güzel, baştan bilseydim, sayfaları ona göre isimlendirirdim.

Hocam program bitince "Halit Hoca'nın önemli katkılarıyla" notunu düşmeyi unutmayacağım.

Tekrar çok teşekkür ederim.

Selam ve saygılarımla.
 
Teşekkürler hayırlı akşamlar
 
Kodu çalışır vaziyette, açıklamalı olarak, başka arkadaşların işine yarayabilir diye buraya bırakıyorum.

Halit Hoca'ya bir kez daha teşekkür...



Kod: 
Private Sub CommandButton25_Click()

[COLOR="Red"]'1-2 numaraları arasında şablon isimli userformda optionbuttonlar ile sayfa seçimi yapılıyor.[/COLOR]
[COLOR="red"]'1[/COLOR]
If şablon.OptionButton1 = True Then
sayfa = "5alt-a"
ElseIf şablon.OptionButton2 = True Then
sayfa = "klasiksinav5a"
ElseIf şablon.OptionButton3 = True Then
sayfa = "8alt-a"
ElseIf şablon.OptionButton4 = True Then
sayfa = "klasiksinav8a"
ElseIf şablon.OptionButton5 = True Then
sayfa = "10alt-a"
ElseIf şablon.OptionButton6 = True Then
sayfa = "klasiksinav10a"
End If

[COLOR="red"]'2-3 numaraları arasında daha önce çalışma kitabında bulunan ve başka bir userformdaki listboxtan seçilerek getirilen resim seçilen sayfaya, seçili hücreye sığdırarak resmi atar.
'2[/COLOR]


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 = 5
If sat < 8 Then sat = 8

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

MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"
3 '
End Sub
 
Kod: 
Private Sub CommandButton25_Click()

If şablon.OptionButton1 = True Then
sayfa = "5alt-a"
ElseIf şablon.OptionButton2 = True Then
sayfa = "klasiksinav5a"
ElseIf şablon.OptionButton3 = True Then
sayfa = "8alt-a"
ElseIf şablon.OptionButton4 = True Then
sayfa = "klasiksinav8a"
ElseIf şablon.OptionButton5 = True Then
sayfa = "10alt-a"
ElseIf şablon.OptionButton6 = True Then
sayfa = "klasiksinav10a"
End If



Dim s1
Dim sat
sat = 0
[COLOR="Red"]Set s1 = Sheets(sayfa)[/COLOR]

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


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

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

MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"

End Sub

Halit Hocam,

Kodu mevcut haliyle çalıştırdığımda kırmızı kısımda "Rune Time Error 9", kırmızı kısımdaki (sayfa) kısmını sildiğimde yeşil kısımda "Rune Time Error 438" hatası veriyor.

Hatalara ait ekran görüntüleri ektedir.
İlk çalıştırdığımda çalışıyordu, bugün deneme yaptım, hata verdi.
 

Ekli dosyalar

  • hata.jpg
    hata.jpg
    19.7 KB · Görüntüleme: 2
  • hata2.jpg
    hata2.jpg
    20.3 KB · Görüntüleme: 1
Son düzenleme:
Kod: 
Dim s1
Dim sat

Kodun içinden şu değişkenleri silince çalıştı Halit Hocam.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst