Bulundugun Satırda Ekleme Yapıpı Üst Satırı Alt Satıra Kopyalama

[yunussss]

mrb arkadaşlar alttaki resimde ve dosyada (gonder.xlsx) gördügünüz gibi benim için A sütünundaki >>> işaretine tek tıklama yaptıgımda >>> işaretinin bulundugu satırı ve alttaki tüm satırları bir satır aşağı alıp boşalan yere bir satırdaki bilgilerin tamamını kopyalayacak yani A4 karşısındaki >>> işarete basınca ekle komutu gibi tüm satırlar aşağı kayacak boş kalan satırada A3'ün tamamını kopyalayacak Bu işlem A sütünundaki bütün satırlar için olacak yani yaklaış 1200 öğretmen var ve rapor girişlerini böyle yapıyorum (sadece L sütünunda basit bir toplama formülü var)

forumu baya araştırdım ama sadece ekle kısmı için bulabildim tamamını yapacak makrao bulamadım
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

If ActiveSheet.Name = "Personel" Then Exit Sub

On Error Resume Next
If Target.Value <> ">>>" Then Exit Sub

Selection.EntireRow.Insert

End Sub

şimdiden yardımlarınız için çok tşk ederim

 

[Huseyinkis]

Merhaba konu başlığını değiştirebilirmisiniz.

 

[yunussss]

Merhaba konu başlığını değiştirebilirmisiniz.

malesef değştiremiyorum bende sonradan farkettim sayfa yenilenince başlık yarım kalmış

 

[Huseyinkis]

malesef değştiremiyorum bende sonradan farkettim sayfa yenilenince başlık yarım kalmış

Ekteki linki incelermisiniz.

http://www.excel.web.tr/f59/acylan-konu-ba-lyoyny-duzeltmek-t81476.html

 

[yunussss]

Ekteki linki incelermisiniz.

http://www.excel.web.tr/f59/acylan-konu-ba-lyoyny-duzeltmek-t81476.html

çok tşkler hüseyin bey şimdi başılığı düzelttim

 

[Huseyinkis]

çok tşkler hüseyin bey şimdi başılığı düzelttim

Ekteki kodları denermisiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
satır = Target.Row
Rows(satır).Insert
Range("B" & satır - 1 & ":F" & satır - 1).Select
Selection.Copy
        Range("B" & satır).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False
Cells(satır, 1).Value = ">>>"
End Sub

 

[yunussss]

çok tşkler hüseyin bey süper olmuş elinize sağlık