Makro ile nesneleri aktarmak

[Ergün GÖKER]

Herkese hayırlı hafta sonları
Bir çalışmamda kullanmak üzere bir çalışma hazırlıyorum. Yapmaya çalıştığımı dosyada açıklamaya çalıştım. Kısaca anlatayım. Bir çalışma sayfasında alt alta üç bölüm mevcut KAZA ÖNCESİ - KAZA ANI - KAZA SONRASI ben ilk önce kaza anına ait kroki çizim çalışması yapıyorum ve belirlediğim alana nesneler yerleştiriyorum. araç,ev,trafik işareti,ağaç vs. yapmak istediğim bir makro kodu ile bu çizimleri hemen altında bulunan alana aktarmak istediğim zaman aktarmak ve üzerinde tekrar düzenlemeler yapmak istiyorum. yine daha sonra kaza anını bir makro ile nesneleri kaza sonrasına aktarmak ve üzerinde düzenleme yapmak istiyorum
örnek Dosyayı ekledim
Amacım aynı krokiyi birkaç kez çizmek istemiyorum. Umarım anlatabilmişimdir. Şimdiden herkese teşekkürler


http://s6.dosya.tc/server5/xpjtb7/KROKI_AKTAR.xls.html

 

[dEdE]

Merhaba,
Sayfanın kod bölümüne eklemelisiniz.

Private Sub CommandButton1_Click()
Range("M10:CL37").Copy Range("M41")
End Sub

Private Sub CommandButton2_Click()
Range("M41:CL76").Copy Range("M80")
End Sub

 

[halit3]

Alternatif kod:

Sub DENEME1()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.BottomRightCell.Row >= 41 And Picture.BottomRightCell.Row <= 76 Then
If Picture.BottomRightCell.Column >= 13 And Picture.BottomRightCell.Column <= 89 Then
Picture.Delete
End If
End If
End If
Next Picture

For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.BottomRightCell.Row >= 10 And Picture.BottomRightCell.Row <= 37 Then
If Picture.BottomRightCell.Column >= 13 And Picture.BottomRightCell.Column <= 89 Then
'MsgBox Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address
s = Picture.TopLeftCell.Row + 33
t = Picture.TopLeftCell.Column
ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
Cells(s, t).Select
ActiveSheet.Paste
End If
End If
End If
Next Picture
Application.CutCopyMode = False
Range("m41").Select

End Sub

Sub DENEME2()

Dim Picture As Object

For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.BottomRightCell.Row >= 80 And Picture.BottomRightCell.Row <= 107 Then
If Picture.BottomRightCell.Column >= 13 And Picture.BottomRightCell.Column <= 89 Then
Picture.Delete
End If
End If
End If
Next Picture


For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.BottomRightCell.Row >= 41 And Picture.BottomRightCell.Row <= 76 Then
If Picture.BottomRightCell.Column >= 13 And Picture.BottomRightCell.Column <= 89 Then
'MsgBox Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address
s = Picture.TopLeftCell.Row + 38
t = Picture.TopLeftCell.Column
ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
Cells(s, t).Select
ActiveSheet.Paste
End If
End If
End If
Next Picture
Application.CutCopyMode = False
Range("m80").Select

End Sub

 

[Ergün GÖKER]

Sayın Hocam dEde size nasıl teşekkür edeceğimi bilemiyorum. İmdadıma ger zaman yetişiyorsunuz. Evet kod biraz istediğime yakın. lakin ben nesneleri aktarmak istiyorum. Çünkü aktarılacak alan hücre sayıları farklı. Aktarırıken çift çizgileri de aktarıp resmi evrak formatını değiştiriyor.

 

[Ergün GÖKER]

Sayın halit hocam teşekkür ederim ilginize ancak

s = Picture.TopLeftCell.Row + 38

satırında kod hata verdi

 

[halit3]

Sayın halit hocam teşekkür ederim ilginize ancak

s = Picture.TopLeftCell.Row + 38

satırında kod hata verdi

bende çalışıyor bu kod

s = Val(Picture.TopLeftCell.Row) + 38

birde böyle dene

 

[Ergün GÖKER]

Halit hocam teşekkür ederim. Ancak ben beceremedim

 

[PLİNT]

Merhaba
Halit Bey'in
Kodlarına "Dim s as long" ekleseniz çalştırabilirdiniz.

Option Explicit

Sub DENEME2()
[COLOR="Red"]Dim s[/COLOR] as Long
[COLOR="Red"]Dim t[/COLOR] as Long
Dim Picture As Object

Alternatif olarak
Ek dosyayı denerseniz:
http://s3.dosya.tc/server7/2jk1s4/KROKI_AKTAR.zip.html

Option Explicit

Private Sub CommandButton1_Click()
Dim x As Shape
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Range("M10:CK36")) Is Nothing Then
x.Copy
Cells(x.TopLeftCell.Row + 31, x.TopLeftCell.Column).PasteSpecial
End If
Next x
End Sub

Private Sub CommandButton2_Click()
Dim x As Shape
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Range("M41:CK75")) Is Nothing Then
x.Copy
Cells(x.TopLeftCell.Row + 39, x.TopLeftCell.Column).PasteSpecial
End If
Next x
End Sub

 

[Ergün GÖKER]

Teşekkürler PLİNT Hocam