Seçilen Satırı Diğer Sayfaya Aktarma,

[Utekiner]

Merhaba;

Sheet1 sayfasında A sütununda başlayıp, AX sütununa kadar veriler bulunmakta, veriler yaklaşık olarak 500. adettir.

Sheet1 deki A sütunundaki hücreleri seçtiğimde, Tüm satıra ait verileri Sheet2 sayfasına aktarmak istiyorum.

Yardımcı olur musunuz. Teşekkürler.

https://s2.dosya.tc/server10/xdqkbs/Satiri_Aktar.xlsx.html

 

[Muzaffer Ali]

Merhaba.
Dosyanız ekte.

https://s2.dosya.tc/server10/pkn0if/Satiri_Aktar.xlsm.html

CTRL+w tuşlarına basarak kopyalama yapabilirsiniz.

 

[Utekiner]

Sn. @dalgalikur Bey ilginiz için teşekkür ederim.
CTRL+W yerine mouse ile A sütununlarına tıkladığımda aktarması için kodda ne gibi bir değişiklik yapılmalıdır.

 

[Muzaffer Ali]

Sheet1 in sayfa adını sağ tıklatın Kod Görüntüle seçin.

Aşağıdaki kodu açılan sayfaya kopyalayın.
Bu kodlar A sütununda bir hücreye tıkladığınızda otomatik çalışır.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Say As Long
    If Target.Column = 1 Then
        With Worksheets("Sheet2")
            Say = .Cells(Rows.Count, "A").End(3).Row + 1
            Range("A" & ActiveCell.Row & ":AX" & ActiveCell.Row).Copy .Range("A" & Say)
        End With
        MsgBox "Kopyalandı."
    End If
End Sub

Eğer tek tıklayınca değil de çift tıklayınca otomatik çalışsın isterseniz yukarıdaki kodları silin aşağıdaki kodları kullanın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Say As Long
    If Target.Column = 1 Then
        Cancel = True
        With Worksheets("Sheet2")
            Say = .Cells(Rows.Count, "A").End(3).Row + 1
            Range("A" & ActiveCell.Row & ":AX" & ActiveCell.Row).Copy .Range("A" & Say)
        End With
        MsgBox "Kopyalandı."
    End If
End Sub

 

[Utekiner]

Sn @dalgalikur Bey ilginiz için teşekkür ederim. Esen kalın.

 

[karam021]

dosyayı indirdim çalışıyor ama fare ile tıklayarak yapmaya çalıştıgımda çalışmıyor kodları belirttiginiz gibi değiştirdim ama çalışmadı başka bir düzenleme yapmam gerekiyormu yoksa sadece kodu degiştirince çalışmasımı gerekir

 

[Muzaffer Ali]

Merhaba @karam021 eğer olmuyorsa 4. mesajda belirttiğim şekilde yapmamışsınız demektir.
4. mesajda yazdıklarımın aynısını yapmalısınız.

 

[NADİR YILDIZ]

muzaffer bey
güzel bir çalışma olmuş.buna ilaveten aklıma şöyle bişey geldi
ctrl ile seçtiğimiz satırları aktarmak ister nasıl bir kod gerekir

iyi çalışmalar

 

[Muzaffer Ali]

Merhaba.

Range("A" & ActiveCell.Row & ":AX" & ActiveCell.Row).Copy .Range("A" & Say)

Satırını silip, yerine aşağıdaki satırı kopyalayın.

Selection.Copy .Range("A" & Say)

 

[NADİR YILDIZ]

Muzaffer bey burada sadece a sütunundakileri aktarıyor
benmi yanlış yaptım ancak istediğim şöyle birşey

ctrl ile örneğin 1-3-7-9.satıları yada 1-2-3-4-5-6-7-8-9 satıları komple seçip aktarmak
yani kısacası isteğe bağlı olarak seçilen satırları komple sonraki sayfaya aktarma imkanı varmı

iyi çalışmalar

 

[Muzaffer Ali]

O zaman diğer kodları silin aşağıdakileri bir module kopyalayın.

Sub test()
    Dim Say As Long
    With Worksheets("Sheet2")
        Say = .Cells(Rows.Count, "A").End(3).Row + 1
        Selection.Copy .Range("A" & Say)
    End With
    MsgBox "Kopyalandı."
End Sub

Kodları isterseniz bir butona ekleyin, yada kısayol tanımlayın. CTRL ile seçiminizi yaptıktan sonra kodları çalıştırın.

 

[NADİR YILDIZ]

Teşekkür ederim

iyi günler dilerim

 

[muhasebeciyiz]

O zaman diğer kodları silin aşağıdakileri bir module kopyalayın.

Sub test()
    Dim Say As Long
    With Worksheets("Sheet2")
        Say = .Cells(Rows.Count, "A").End(3).Row + 1
        Selection.Copy .Range("A" & Say)
    End With
    MsgBox "Kopyalandı."
End Sub

Kodları isterseniz bir butona ekleyin, yada kısayol tanımlayın. CTRL ile seçiminizi yaptıktan sonra kodları çalıştırın.

Sayın Muzaffer Ali Bey ;

Bu kod tek satırdaki seçilenleri kopyalamaktadır.
Ben bundan faklı olarak A sutununda birden fazla satırı seçerek seçtiğim hücreleri kopyalamak.
Eğer mümkün olursa ve kodu paylaşırsanız sevinirim.Saygılarımla.

 

[Muzaffer Ali]

Sayın @muhasebeciyiz alıntı yaptığınız mesajdaki kodlar sizin istediğinizi yapıyor.

 

[zaruri]

Muzaffer Ali Hocam;

"Onay kutusu ile fiyat çağıma"

Başlığında da aynı dosya ile sormuştum.
Bu başlıktan ve yardımınızla aldığım formülle yapmaya çalıştığım listenin,
"aktarılan satırın" aktardığımız yerde Başlangıç satırını ayarlayamadım.

Ayrıca, satır renk ve font karakteriyle aktarılıyor, sadece bilgilerin aktarılması için
yardımlarınızı bekliyoruz.

 

[MyMamoste]

Merhaba hocam, Ben de Aileler ve Pasif diye iki sayfa var, Aileler sayfasındaki bir satıra çift tıklayınca Pasif sayfasına tamamen taşıyorum aşağıdaki kodlar ile, önce kopyalama yapıyorum sonra Activecell.EntireRow.Delete ile o satırı siliyorum, bu şekilde olanı ihtiyacımı görüyor.

1. Aileler kısmından A sütununda bir hücreye tıklayınca aktarma ve silme gerçekleşiyor lakin aşağıdaki kodda yer alan

If Target.Row < 2 Or Target.Column < 4 Or Target.Column > 16 Or Target.Column = 13 Or Target.Column = 14 Then

Kısmında Run-time error '424' object required hatası veriyor.

Pasif kısmından aşağıdaki kod ile Aileler kısmına çift tıklama ile geri alınca bir sıkıntı çıkmıyor..

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Say As Long
    If Target.Column = 1 Then
        Cancel = True
        With Worksheets("Aileler")
            Say = .Cells(Rows.Count, "A").End(3).Row + 1
            Range("A" & ActiveCell.Row & ":AX" & ActiveCell.Row).Copy .Range("A" & Say)
            ActiveCell.EntireRow.Delete
        End With
        MsgBox "Kayıtlı Aile Aileler Sayfasına Taşındı."
    End If
End Sub

Aşağıdaki kodu nasıl değiştirmeliyim. Nerede ekleme ve çıkarma yapmalıyım hocam. Ado ile DB sayfasından veri çekme ile ilgili kodları Yorum Kodlarına çevirince yani iptal edince sıkıntı yok, ama aktif edince sıkıntı çıkıyor. Hem taşıma hem de DB den veri çekme kodları Çift Worksheet BeforeDoubleClick kısmında olunca sorun çıkıyor. Nasıl bir çözüm üretebiliriz hocam?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'Seçilen satırı çift tıklama ile pasif hale getirme

Dim Say As Long
    If Target.Column = 1 Then
        Cancel = True
        With Worksheets("Pasif")
            Say = .Cells(Rows.Count, "A").End(3).Row + 1
            Range("A" & ActiveCell.Row & ":O" & ActiveCell.Row).Copy .Range("A" & Say)
            ActiveCell.EntireRow.Delete
           
        End With
        MsgBox "Kayıtlı Aile Pasif Sayfasına Taşındı."
    End If

'DB sayfasından Userform Listbox'a Ado ile veri çekme.   

If Target.Row < 2 Or Target.Column < 4 Or Target.Column > 16 Or Target.Column = 13 Or Target.Column = 14 Then
Exit Sub
Else
hucre = Target.Address

End If

kolon = Mid(hucre, 2, 1)            'Sütun Harfini verir
satir = Target.Row                  'Satır sayısını verir
baslik = kolon & 1                  'Sütun ve satırı birleştirir örneğin A5 gibi
Kriter = Range("" & baslik & "")    'Veri tabanında yer alan başlık ile tablodaki başlığı alır

Dim baglanti As New ADODB.Connection
Dim rs As New ADODB.Recordset
yol = Application.ThisWorkbook.FullName 'Bu çalışma kitabı demek
baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

If kolon = "E" Then
sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "F" Then
sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "D" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "G" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "H" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "I" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "J" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "K" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic

ElseIf kolon = "L" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic


ElseIf kolon = "O" Then

sorgu = "select Distinct(" & "[" & Kriter & "]" & ") from [DB$]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockOptimistic
End If

With UserForm1.ListBox1
.Column = rs.GetRows

End With


rs.Close
baglanti.Close

UserForm1.TextBox1 = Target.Row
UserForm1.TextBox2 = Target.Column
UserForm1.Show



End Sub

 

[MyMamoste]

Yardım edecek kimse yok mu hocalar?