Çift Tıklayarak Veri Aktarma

[1Al2Ver]

Merhabalar,

Sayfa1'de kayıtlı bir veriye çift tıkladığımda, tıklanan veriye ait bilgilerin, verinin solunda kalan tarihe göre, Sayfa2'ye aktarılmasını istiyorum,

Örnekleme Ek'li dosyada, Sayfa1'dedir,

Teşekkür ederim.

 

[meslan]

Merhaba
Kod:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [c2:C65535]) Is Nothing Then Exit Sub
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.[A2:I65536] = ""
a = Target.Row
b = Target.Value
S = 2
For X = a To [c65536].End(3).Row
If Cells(X, 3) = b Then
s2.Cells(S, 1) = WorksheetFunction.Max(s2.[a:a]) + 1
s2.Range("B" & S & ":I" & S) = s1.Range("B" & X & ":I" & X).Value
S = S + 1
End If
Next
s2.Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[N.Ziya Hiçdurmaz]

Yanıt

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim s1, s2 As Worksheet
Dim son, s As Integer
If Intersect(Target, [c2:c10000]) Is Nothing Then Exit Sub
Set s1 = Sayfa1
Set s2 = Sayfa2
son = s2.Cells(65536, "b").End(xlUp).Row + 1
Range(s1.Cells(Target.Row, "b"), s1.Cells(Target.Row, "f")).Copy s2.Cells(son, "b")
s = 1
deg = WorksheetFunction.CountA(s2.Range("b2:b65536"))
Do While s2.[b2] <> ""
s2.Cells(s + 1, "a") = s
s = s + 1
If s > deg Then Exit Do
Loop
s2.Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[1Al2Ver]

Merhaba
Kod:

Sayın meslan, merhaba

Öncelikle çözüm için teşekkür ederim,

Aktarmada sorun yok, ancak 2 nci bir seçim yaptığımda (yani başka bir malzemeye çift tıklamada) Sayfa2 G2,H2 ve I2 hücrelerindeki formüllerimi siliyor, bu hücrelerde, toplam miktar, toplam tutar ve ortalama hesabı yapılmakta,

Aktarma esnasında adı geçen hücrelerdeki formüllerin silinmemesi gerekmektedir, kodda bir değişiklik gerekiyor sanırım,

Teşekkür ederim.

 

[1Al2Ver]

Sayın meslan,

Formüllerdeki "I" yı "F" yaptım,

Sorun yok,

Teşekkür ederim.

 

[1Al2Ver]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim s1, s2 As Worksheet
Dim son, s As Integer
If Intersect(Target, [c2:c10000]) Is Nothing Then Exit Sub
Set s1 = Sayfa1
Set s2 = Sayfa2
son = s2.Cells(65536, "b").End(xlUp).Row + 1
Range(s1.Cells(Target.Row, "b"), s1.Cells(Target.Row, "f")).Copy s2.Cells(son, "b")
s = 1
deg = WorksheetFunction.CountA(s2.Range("b2:b65536"))
Do While s2.[b2] <> ""
s2.Cells(s + 1, "a") = s
s = s + 1
If s > deg Then Exit Do
Loop
s2.Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

Sayın N.Ziya Hiçdurmaz, merhaba

Alternatif çözüm için teşekkür ederim, bayramınız kutlu olsun,

Saygılarımla.

 

[N.Ziya Hiçdurmaz]

Sayın 1Al2Ver sizinde bayramınız mübarek olsun