çift tıklama

[aydgur]

bir katılımcımızdan edindiğim aşağıda kod için yardım rica ediyorum.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Application.ScreenUpdating = False
If Target = "" Then Exit Sub
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
Set s1 = Sheets("açık")
Set s2 = Sheets("takas")

son = s2.Cells(65536, 1).End(3).Row + 1
s2.Range("a" & son & ":j" & son & "").Value = Range("a" & Target.Row & ":j" & Target.Row & "").Value
Target.Offset(1, 0).Select
Set s1 = Nothing
Set s2 = Nothing
Application.ScreenUpdating = True
End Sub
yukarıdaki kodda takas sayfasının örneğin O2 hücresinden itibaren ilk boş satırdan itibaren nasıl aktarabilirim , şimdiden teşekkürler

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 
On Error Resume Next 
Application.ScreenUpdating = False 
If Target = "" Then Exit Sub 
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub 
Set s1 = Sheets("açık") 
Set s2 = Sheets("takas") 
son = s2.Cells(65536, "o").End(3).Row + 1 
s2.Range("o" & son & ":x" & son & "").Value = Range("a" & Target.Row & ":j" & Target.Row & "").Value 
Target.Offset(1, 0).Select 
Set s1 = Nothing 
Set s2 = Nothing 
Application.ScreenUpdating = True 
End Sub

 

[aydgur]

teşekkür ederim ,peki o aktarılan satırın "açık" sayfasından da silinmesi istersem ne yapabilirim.

 

[Levent Menteşoğlu]

Kodu aşağıdaki ile değiştirin. Eğer tüm satırı silmek isterseniz, "clear" komutu yerine "delete" komutunu yazın.

[LEFT]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 
On Error Resume Next 
Application.ScreenUpdating = False 
If Target = "" Then Exit Sub 
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub 
Set s1 = Sheets("açık") 
Set s2 = Sheets("takas") 
son = s2.Cells(65536, "o").End(3).Row + 1 
s2.Range("o" & son & ":x" & son & "").Value = s1.Range("a" & Target.Row & ":j" & Target.Row & "").Value 
[B][COLOR=blue]s2.Range("a" & Target.Row & ":j" & Target.Row & "").clear[/COLOR][/B]
Target.Offset(1, 0).Select 
Set s1 = Nothing 
Set s2 = Nothing 
Application.ScreenUpdating = True 
End Sub[/LEFT]

 

[aydgur]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Application.ScreenUpdating = False
If Target = "" Then Exit Sub
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub

Set s2 = Sheets("takas")
son = s2.Cells(65536, 1).End(3).Row + 1
s2.Range("o" & son & ":v" & son & "").Value = Range("c" & Target.Row & ":j" & Target.Row & "").Value
Target.Offset(1, 0).Select

Set s2 = Nothing
Application.ScreenUpdating = True
End Sub
peki bu kodda aynı sayfadaki c ve j sütunlarındaki bilgileri yine aynı sayfadaki o 3 v 3 sütunlarında itibaren nasıl yapabilirim ?

 

[aydgur]

çift tıklama aynı sayfada

takas sayfasındaki a2 ve j2 den itibaren olan hücreleri aynı sayfada o4 v4 hücrelerinden itibaren nasıl aktarabilirim

 

[Levent Menteşoğlu]

Dosyanızı eklerseniz onun üzerinden gidelim.

 

[aydgur]

çift tıklama aynı sayfada

aynı sayfadaki tabloya aktarmak istiyorum

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Application.ScreenUpdating = False
If Target = "" Then Exit Sub
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
Set s2 = Sheets("takas")
son = [B][COLOR=blue]worksheetfunction.counta(s2.[o4:o65536])+ 4
[/COLOR][/B]s2.Range("o" & son & ":v" & son & "").Value = Range("c" & Target.Row & ":j" & Target.Row & "").Value
Target.Offset(1, 0).Select
Set s2 = Nothing
Application.ScreenUpdating = True
End Sub

 

[aydgur]

sn leventm 4.sarır değil 11.satırdan itibaren yazıyor.

 

[Levent Menteşoğlu]

Bu durumda O sütununda aşağılarda başka veriler var demektir. O65536 kısmındali 65536 üst limitini değiştirin.

 

[aydgur]

Evet O sütununun bir hücresini bilmeden doldurmuşum şimdi oldu teşekkürler.