Seçili satırları seçilen sayfalara aktarma

[NADİR YILDIZ]

Satırı komple seçip.örneğin 7.satırı isteğe göre 2 sayfaya veya 20 sayfaya aktarım yapabilirmiyiz.burada sadece tek satır değil değişik satırları seçerek 7.10.13.50 vb….değişik sayfalara SAYFA 2 - 3 - 20 -50. aktarmak istiyorum.burada önemli olan T sütunu ile sınırlı kalmayacak yada 15.satırla sınırlı kalmayacak.yada 4 sayfayla sınırlı kalmayacak.liste geniş ve uzun olacak.

İyi çalışmalar

 

[Ömer]

Merhaba,

Deneyiniz.
syf = Array("Sayfa2", "Sayfa4") seçili satırlar bu iki sayfaya aktarılması için yazdım. Siz çoğaltabilir yada azaltabilirsiniz.

Sub aktar()

    Dim syf(), i As Byte, hc As Range, son As Long, rng As Range
  
    syf = Array("Sayfa2", "Sayfa4")
    Set rng = Selection.Rows
          
    For i = 0 To UBound(syf)
        For Each hc In rng
            son = Sheets(syf(i)).Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range(hc.Address).Copy Sheets(syf(i)).Cells(son, "A")
        Next
    Next i
  
End Sub

 

[NADİR YILDIZ]

Ömer bey teşekkür ederim.
ilk bölümü istediğim gibi olmuş
burada sadece 2 ve 4 .sayfalara aktarıyor
butona basınca açılacak bir pencere ile 3-5-7 satıları sayfa 2 sayfa 7 sayfa 10 gibi seçerek aktarmak mümkünmüdür ?
açılan pencerede seçilecek sayfa isimlerini sekmelerdeki sayfa isimlerinden alırsa çok iyi olur sayfa isimleri değişilik gösterebiliyor

teşekkürler

 

[Ömer]

Userformu açmak için sayfaya bir buton ekleyin ve kodları module yazarak butona bağlayın.

Sub formac()
    UserForm1.Show 0
End Sub

VBA ekranına geçin bir tane userform oluşturun, forma bir listbox ve CommandButton ilave ederek aşağıdaki kodları forma ilave edin.
İşleyişi: Sayfadan alan-satır seçin, formu açın aktarılacak sayfaları seçin ve formdaki butona basarak aktarın.

Private Sub CommandButton1_Click()

    Dim syf As String, i As Byte, hc As Range, son As Long, rng As Range, j As Integer
  
    Set rng = Selection.Rows
  
    Application.ScreenUpdating = False
  
    For j = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(j) = True Then
            syf = ListBox1.List(j, 0)
            For Each hc In rng
                son = Sheets(syf).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Range(hc.Address).Copy Sheets(syf).Cells(son, "A")
            Next
        End If
    Next j
    Range("A7").Select
    MsgBox "Aktarım Bitti", vbInformation
  
  
End Sub

Private Sub UserForm_Initialize()

    Dim syf As Worksheet, s As Integer
  
    ListBox1.ColumnCount = 1
    ListBox1.ColumnWidths = "50"
    ListBox1.MultiSelect = 1
  
    For Each syf In Worksheets
        If ActiveSheet.Name <> syf.Name Then
            s = s + 1
            ListBox1.AddItem
            ListBox1.List(s - 1, 0) = syf.Name
        End If
    Next

End Sub

 

[NADİR YILDIZ]

Ömer bey teşekkür ederim
dediğiniz gibi yaptım muhtelif satırları seçiyorum.ancak listboxta sayfalar gelmiyor
ben biryerde yanlışmı yaptım

teşekkürler

 

[Ömer]

Benim verdiğim kodları kullanmamışsınız. Eki inceleyin.

 

[NADİR YILDIZ]

yanlış bişey yaptığım belliydi zaten

teşekkür ederim.
iyi çalışmalar

 

[Ömer]

Önemli değil, iyi çalışmalar.