Çift tıklayarak veri kopyalayıp başka sheette alt alta verileri yapıştırma

[u.L.a.s]

Merhabalar

Aşağıdaki linkte örnek excel dosyasında detaylı olarak istediğimi anlattım.

Kısaca burdada izah etmek isterim.

Sheet1 de çift tıklayarak kopyalamak istediğim veriler var. Bu kopyalanan verileri Sheet2 de A sütunu 2. satırdan itibaren yapıştırsın istiyorum

Fakat farklı kopyalama seçenekleri istiyorum.

1. si
Eğer sütun başındaki hücreye çift tıklarsam o sütunda bulunan verileri kopyalayıp aradaki boşlukları almadan alt alta Sheet2 de A sütunu 2. satırdan itibaren yapıştırsın

2. si
Eğer Satır başındaki hücreye çift tıklarsam o satırda bulunan verileri kopyalasın. aradaki boşlukları almadan alt alta Sheet2 de A sütununda 2.satırdan itibaren yapıştırsın

3.sü
Tek tek seçim yaparak olan kopyalama yapıştırma olacak. Yani herhangi bir sütun ve satır başı haricinde D ve M aralığında ki verilere çift tıkladığımda o hücredeki veriyi Sheet2 de A2 ye yapıştırsın. 2. bir veri çift tıkladığımda hemen altındaki boş hücre A3 e bu veriyi yapıştırsın. ve sırayla böyle devam etsin.

Bilgi ve yardımlarınızı rica ederim

Teşekkürler


http://s5.dosya.tc/server2/2muep6/kopyalayapistir.rar.html

 

[PLİNT]

Merhaba
Şöyle deneyin.
http://www.upturkey.com/download.php?file=965Kopya.xls

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
x2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(3).Row + 1
If Target.Column >= 4 And Target.Column <= 13 And Target.Row = 1 Then
Columns(Target.Column).SpecialCells(xlCellTypeConstants).Copy Sheets("Sheet2").Range("a" & x2)
Sheets("Sheet2").Range("a" & x2).Delete Shift:=xlUp
End If
If Target.Column = 1 And Target.Row > 1 Then
Range("d" & Target.Row & ":m" & Target.Row).SpecialCells(xlCellTypeConstants).Copy
Sheets("Sheet2").Range("a" & x2).PasteSpecial , Transpose:=True
End If
If Intersect(Target.Cells, Range("D2:m" & Cells(Rows.Count, Target.Column).End(3).Row)) Is Nothing Then Exit Sub
Target.Copy Sheets("Sheet2").Range("a" & x2)
End Sub

 

[ÖmerBey]

Sayfanın Kod bölümüne uygulayınız. Aralıkları kendinize göre değiştiriniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Set s2 = Sheets("Sheet2")
If Not Intersect(Target, Range("[COLOR="Red"]D1:M1[/COLOR]")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    For a = 2 To Cells(65500, Target.Column).End(3).Row
        If Cells(a, Target.Column) <> "" Then
            s2.Cells(son, "A") = Cells(a, Target.Column)
            son = son + 1
        End If
    Next
    
ElseIf Not Intersect(Target, Range("[COLOR="red"]A2:A6[/COLOR]")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    For a = 4 To Cells(Target.Row, 256).End(2).Column
        If Cells(Target.Row, a) <> "" Then
            s2.Cells(son, "A") = Cells(Target.Row, a)
            son = son + 1
        End If
    Next
    
ElseIf Not Intersect(Target, Range("[COLOR="red"]D2:M6[/COLOR]")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    If Target <> "" Then s2.Cells(son, "A") = Target
        
End If
  
MsgBox "Aktardım."
End Sub

 

[u.L.a.s]

Çok çok teşekkür ederim emeğiniz ve bilgileriniz için

Çok ufak bir sorum olacak.

Hani hücreye çift tıklıyoruz ya.tamam veri aktarılıyor. ama Bu çift tıklama sonrası o hücre içeriği açılıyor hücre içerisindeki kursör yanıp sönmeye başlıyor. yani hücre içeriğini değiştirme konumuna geçiyor.

Bunun olmaması için ne yapılabilir.

 

[u.L.a.s]

Bir sorum daha var

bu listede Sheet1 ana verilerimin olduğu sheet. Sheet2 ye ise D - M arasındaki verileri alt alta sıralatıyoruz.

Şimdi çift tıkladık kopyaladı sheet2 de sıraladı bu verileri. Ama sheet1 de A B C sütunlarımdada bazı veriler var ya. bu verileride karşısına C ve D sütununa getirsin

Örneğin A4 hücresine çift tıkladım karşısındaki veriler olan c1-c5-c9 verilerini Sheet2 de A sütununda alt alta sıraladı.

Sheet2 de C ve D sütununa bu verilerin karşılığı olan Sheet1 deki A sütunu ve B sütunundaki verileride yazsın istiyorum.

Yani Sheet2 de A sütununda c1-c5-c9 sıralıysa karşılığında Sheet1 de A sütununda c var B sütunundada c var.

Bu iki veriyide Sheet2 de C ve D sütununda c1in karşısına c,c5 in karşısına c, c9 un karşısına c olarak yazması gerekiyor.

Aşağıdaki resim örneğindeki gibi.




Edit : Bu soruma çözüm buldum. aşağıdaki kod düzeniyle bunu sağladım. Bir üst soru için bilgi iletirseniz sevinirim

Sub Verigetir ()
    Dim i%, xls As Range
    For i = 1 To Sayfa2.Range("A65536").End(3).Row
        Set xls = Sayfa1.Range("D:L").Find(Sayfa2.Cells(i, "A"), , , 1)
        If Not xls Is Nothing Then
            Sayfa2.Cells(i, "C") = Sayfa1.Cells(xls.Row, "A")
            Sayfa2.Cells(i, "D") = Sayfa1.Cells(xls.Row, "B")
        End If
    Next i
    Set xls = Nothing: i = Empty
End Sub

 

[ÖmerBey]

Kodu aşağıdaki şekilde düzenleyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Set s2 = Sheets("Sheet2")
If Not Intersect(Target, Range("D1:M1")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    For a = 2 To Cells(65500, Target.Column).End(3).Row
        If Cells(a, Target.Column) <> "" Then
            s2.Cells(son, "A") = Cells(a, Target.Column)
            son = son + 1
        End If
    Next
    [COLOR="Red"]Cancel = True[/COLOR]
    
ElseIf Not Intersect(Target, Range("A2:A6")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    For a = 4 To Cells(Target.Row, 256).End(2).Column
        If Cells(Target.Row, a) <> "" Then
            s2.Cells(son, "A") = Cells(Target.Row, a)
            [COLOR="red"]s2.Cells(son, "C") = Target
            s2.Cells(son, "D") = Target.Offset(0, 1)[/COLOR]
            son = son + 1
        End If
    Next
    [COLOR="red"]Cancel = True[/COLOR]
    
ElseIf Not Intersect(Target, Range("D2:M6")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    If Target <> "" Then s2.Cells(son, "A") = Target
    [COLOR="red"]Cancel = True[/COLOR]
    
End If

End Sub

 

[u.L.a.s]

Teşekkür ederim.

Son bir soru

A1 hücresine tıklayıncada D-M aralığındaki tüm verileri Sheet2 de A sütununa boşluklar olmadan sıralasın. Yani Bu işlemlede tüm veriyi seçip kopyalayıp yapıştırmış olucam.

Bilgi ve emekleriniz için Teşekkür ederim tekrardan

 

[ÖmerBey]

Peki bu sıralama satır satır mı olacak, yoksa sütun sütun mu?
Yani a1 verisinden sonra b1 mi olacak a2 mi?
Bir de A ve B sütunlarındaki verileri de aktaracak mı?

 

[u.L.a.s]

a1 a2 diye gidip b1 b2 şeklinde devam edebilir. yani satır satır olabilir.

Sütun sütunda olabilir hiç farketmez.

A ve B sütunlarını almasına gerek yok. D-M aralığındaki verileri sıralıyoruz A sütununda.

 

[ÖmerBey]

Yukarıdaki kodda en sondaki End if satırının üzerine aşağıdaki kodu ilave ediniz.

ElseIf Not Intersect(Target, Range("A1")) Is Nothing Then
    son = s2.Range("A65500").End(3).Row + 1
    For a = 2 To 6
        For b = 4 To 13
            If Cells(a, b) <> "" Then
                s2.Cells(son, "A") = Cells(a, b)
                son = son + 1
            End If
        Next
    Next
    Cancel = True

 

[u.L.a.s]

Üstadım emeğine bilgine sağlık.

Çok teşekkür ederim. harika oldu.