Kodu Revize Etmek İçin Yardım

[BedriA]

Arkadaşlar,

Aşağıdaki kod ile sayfaya textboxtaki veriyi aktarıyorum.
Veriler E8'den başlayarak alt alta aktarılıyor.

Private Sub CommandButton20_Click()



If şablon.OptionButton1 = True Then
Son_Dolu_Satir = Sheets("5alt-a").Range("E65536").End(3).Row
                       
Bos_Satir = Son_Dolu_Satir + 1
Sheets("5alt-a").Range("E" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(Sheets("liste").Range("E:E")) + 1
Sheets("5alt-a").Range("E" & Bos_Satir).Value = TextBox6.Text
                        
MsgBox "Soru kağıda aktarıldı!", vbInformation, "      Bilgi"
Workbooks("SINAVMATİK").Save
TextBox6.Text = ""
End If

'8alt

If şablon.OptionButton3 = True Then
Son_Dolu_Satir = Sheets("8alt-a").Range("E65536").End(3).Row
                       
Bos_Satir = Son_Dolu_Satir + 1
Sheets("8alt-a").Range("E" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(Sheets("liste").Range("E:A")) + 1
Sheets("8alt-a").Range("E" & Bos_Satir).Value = TextBox6.Text
                        
MsgBox "Soru kağıda aktarıldı!", vbInformation, "      Bilgi"
Workbooks("SINAVMATİK").Save
TextBox6.Text = ""
End If

'10alt

If şablon.OptionButton5 = True Then
Son_Dolu_Satir = Sheets("10alt-a").Range("E65536").End(3).Row
                       
Bos_Satir = Son_Dolu_Satir + 1
Sheets("10alt-a").Range("E" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(Sheets("liste").Range("E:E")) + 1
Sheets("10alt-a").Range("E" & Bos_Satir).Value = TextBox6.Text
                        
MsgBox "Soru kağıda aktarıldı!", vbInformation, "      Bilgi"
Workbooks("SINAVMATİK").Save
TextBox6.Text = ""
End If

End Sub

Aşağıdaki kod ile aynı sayfaya, yine E8'den başlayarak resim atıyorum.
Bunda da her resim bir öncekinin altındaki hücreye yerleşiyor.

Private Sub CommandButton25_Click()

If şablon.OptionButton1 = True Then
sayfa = "5alt-a"

ElseIf şablon.OptionButton3 = True Then
sayfa = "8alt-a"

ElseIf şablon.OptionButton5 = True Then
sayfa = "10alt-a"

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

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

End Sub

Sorun şurada:
Sayfaya önce Textbox'taki veriyi aktardım, diyelim. Bu veri E8'e yerleşti.
Sonra da bir resim atınca, resim E9'a yerleşmesi gerekirken E8'e yerleşiyor.
Peş peşe sadece resim atarsam sorun yok, alt alta yerleşiyor. Ama bir metin ardından resim atarsam, sıra bozuluyor.

Sayfaya resim aktaran koda "Eğer hücrede metin var ise bir sonraki hücreye geç" komutunu nasıl ekleyebiliriz?

 

[halit3]

kod:

Private Sub CommandButton25_Click()

If şablon.OptionButton1 = True Then
sayfa = "5alt-a"

ElseIf şablon.OptionButton3 = True Then
sayfa = "8alt-a"

ElseIf şablon.OptionButton5 = True Then
sayfa = "10alt-a"

End If


[COLOR="red"]Son_Dolu_Satir = Sheets(sayfa).Range("E65536").End(3).Row[/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


[COLOR="Red"]If Son_Dolu_Satir >= sat Then sat = Son_Dolu_Satir + 1[/COLOR]

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("E65536").End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range("E" & Bos_Satir).Value = "Resim"
MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"

End Sub

 

[BedriA]

Halit Hocam,

İlk kırmızı yerdeki "5alt-a" yerine başka bir şey yazılması gerekmiyor mu?

 

[halit3]

Son_Dolu_Satir = Sheets([COLOR="Red"]sayfa[/COLOR]).Range("E65536").End(3).Row

Bunu unutmuşum senin bunları yapacağını düşünüyorum.

 

[BedriA]

Son_Dolu_Satir = Sheets([COLOR="Red"]sayfa[/COLOR]).Range("E65536").End(3).Row

Bunu unutmuşum senin bunları yapacağını düşünüyorum.

Halit Hocam,

İşin doğrusu ben programlama diline hakim değilim,
tek avantajım biraz matematik bilmek herhalde.

"p ise q" mantığı yani.

Siz de olmasanız sorularım hep cevapsız kalıyor.
Hakkınızı helal edin lütfen.

Selam ve saygılarımla.