Tarih Aralığı Kadar Kopyala-Yapıştır

[Lecay]

Arkadaşlar merhaba,

Ekli dosyada "C" ile "H" sütunu arasındaki verileri "K" ve "Q" sütunları gibi tarih aralığı kadar alt alta kopyalayıp yapıştırmak istiyorum. Bunun gibi çoklanması gereken yaklaşık 5000 satır var. Yardım edebilir misiniz ?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Multiple_Data()
    Dim S1 As Worksheet, My_Data As Variant
    Dim My_Date As Date, Count_Data As Long
    Dim Process_Time As Double, X As Long
    
    Process_Time = Timer
    
    Set S1 = Sheets("Sheet1")
    
    My_Data = S1.Range("C6:H" & S1.Cells(S1.Rows.Count, "C").End(3).Row).Value
    
    S1.Range("K6:Q" & S1.Rows.Count).Clear
    S1.Range("K6:K" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
    S1.Range("N6:O" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
    S1.Range("P6:P" & S1.Rows.Count).NumberFormat = "$#,##0.00_);($#,##0.00)"
    
    ReDim My_List(1 To S1.Rows.Count, 1 To 7)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        For My_Date = My_Data(X, 3) To My_Data(X, 4)
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Date
            My_List(Count_Data, 2) = My_Data(X, 1)
            My_List(Count_Data, 3) = My_Data(X, 2)
            My_List(Count_Data, 4) = My_Data(X, 3)
            My_List(Count_Data, 5) = My_Data(X, 4)
            My_List(Count_Data, 6) = My_Data(X, 5)
            My_List(Count_Data, 7) = My_Data(X, 6)
        Next
    Next
    
    S1.Range("K6").Resize(Count_Data, 7) = My_List
    S1.Columns("K:Q").AutoFit
    
    Set S1 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[Lecay]

Deneyiniz.

Option Explicit

Sub Multiple_Data()
    Dim S1 As Worksheet, My_Data As Variant
    Dim My_Date As Date, Count_Data As Long
    Dim Process_Time As Double, X As Long
   
    Process_Time = Timer
   
    Set S1 = Sheets("Sheet1")
   
    My_Data = S1.Range("C6:H" & S1.Cells(S1.Rows.Count, "C").End(3).Row).Value
   
    S1.Range("K6:Q" & S1.Rows.Count).Clear
    S1.Range("K6:K" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
    S1.Range("N6:O" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
    S1.Range("P6:P" & S1.Rows.Count).NumberFormat = "$#,##0.00_);($#,##0.00)"
   
    ReDim My_List(1 To S1.Rows.Count, 1 To 7)
   
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        For My_Date = My_Data(X, 3) To My_Data(X, 4)
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Date
            My_List(Count_Data, 2) = My_Data(X, 1)
            My_List(Count_Data, 3) = My_Data(X, 2)
            My_List(Count_Data, 4) = My_Data(X, 3)
            My_List(Count_Data, 5) = My_Data(X, 4)
            My_List(Count_Data, 6) = My_Data(X, 5)
            My_List(Count_Data, 7) = My_Data(X, 6)
        Next
    Next
   
    S1.Range("K6").Resize(Count_Data, 7) = My_List
    S1.Columns("K:Q").AutoFit
   
    Set S1 = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

Korhan bey çok teşekkür ederim. Harikasınız!