Soru kopyalanan bir veriyi makro ile nasıl kopyalarım

[MaxFlow]

Merhabalar,
Aşağıda belirtmiş olduğum kodta vermiş olduğum veriyi for döngüsünde 17 kez yaptırmaktayım fakat A1 de olan veriden 12898 adet var. her defasında sheets(4).range("A2") vermden bu döngüde nasıl yapabilir. Kısaca 17 kez kopyaladıktan sonraki kopyalanan verinin bir alt satırındaki veriyi seçerek aynı işlemi ona da yaptırmam gerek taki 12898inci satıra kadar. VBA çok yeniyim acil yardımlarınızı bekliyorum.

Sub FILL()

For x = 1 To 17

Sheets(4).Range("A1").Copy Destination:=Cells(ActiveCell.Row + 1, 2)
ActiveCell.Offset(1, 0).Select

Next

End Sub

 

[Korhan Ayhan]

Küçük bir örnek dosya paylaşarak yapmak istediğiniz işlemi açıklarsanız daha hızlı yanıt alabilirsiniz.

Harici dosya yükleme sitelerine örnek dosyanızı yükleyip linkini paylaşabilirsiniz.

 

[MaxFlow]

örnek.xlsx

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

Sheet1 de B2 hücresini sheet2 deki b2 hücresine 17 kez alt alta kopyalamam gerekli ve bu işlemi B3 ten B10 kadar olan diğer hücreler içinde yapmam gerekli. Orjinal Excelde ise Sheet1 deki B2 den B10 a kadar olan veri 12898 tanedir. Yardımlarınızı rica ederim.

 

[MaxFlow]

Korhan bey yardımcı olabilir misiniz?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Veri As Variant
    Dim X As Long, Say As Long, Y As Byte
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    S2.Columns(2).Clear
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S1.Range("B2:B" & Son).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = 1 To 17
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 1)
            Next
        End If
    Next
    
    If Say > 0 Then
        S2.Range("B1").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[MaxFlow]

Korhan Bey cok tesekkur ederim calıştı çok sağolun. Merakımdan öğrenmek için bu işlemin bir başka varyosyonu var.

örnek yatay.xlsx

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

Bu örnekte de Sheet1 de yanyana 17tane olan veriyi kopyalıyıp Sheet2 deki gibi alt alta yapstrmak istiyorum ve bunlar yine 12 bin veri olduğunu varsayarsak kod ta nasıl bir değişiklik yapılmalı yada sil baştan mı yapılmalı kusura bakmayın bu konuda çok yeniyim. Yardımcı olabilirmisiniz?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Veri As Variant
    Dim X As Long, Say As Long, Y As Byte
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet3")
    
    S2.Columns(1).Clear
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = S1.Range("A1:Q" & Son).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = 1 To 17
                Say = Say + 1
                Liste(Say, 1) = Veri(X, Y)
            Next
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A1").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[MaxFlow]

Korhan bey tekrar teşekkür ederim. Çalıştı fakat Sheet1 A:Q arasındaki ilk satırı Sheet2 de ilk 17 satıra kopyalmasını planlıyordum. Sanırım sheet1 in 918.satırını kopylamış. Sizlere benim çalışma dosyamı iletiyorum. Fikir verebilir diye. https://we.tl/t-GAbFJuNuTD

 

[Korhan Ayhan]

Paylaştığınız dosyada Sheet1 A:Q arasında sadece B sütununda veri var . Diğer hücreler boş görünüyor.

Bu sebeple tam olarak ne yapmaya çalıştığınızı maalesef anlamadım.

 

[MaxFlow]

Burada bazı hücreler boş olduğu için boş olanları oraya boş olarak vermeli.

 

[MaxFlow]

https://we.tl/t-VcrW48Mmnh Beklentim aslında böleydi A51 e kadar verleri sheet1 den manuel doldurdum olduğu gibi boşsada kopyalamak çünkü dolularıda kopyalıcak bos olanlar bos olarak böle kalmasıydı.

Screenshot_1.png

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

 

[Korhan Ayhan]

B sütunu hep dolu oluyor mu?

 

[MaxFlow]

Evet diğer alanlar hep dolu sadece A sütununu doldurmalıyım.

 

[Korhan Ayhan]

Deneyiniz.

B sütununda en son dolu hücreye kadar işlem yapar.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Veri As Variant
    Dim X As Long, Say As Long, Y As Byte
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    S2.Columns(1).Clear
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = S1.Range("A1:Q" & Son).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = 1 To 17
            Say = Say + 1
            Liste(Say, 1) = Veri(X, Y)
        Next
    Next
    
    If Say > 0 Then
        S2.Range("A1").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[MaxFlow]

Tamam oldu bu sefer çok teşekkür ederim elinize emeğinize sağlık.