Code to get data from data 10 lines away get 1 line

[Excelpromax123]

Hello everyone. I have a data range A1:B10000. I want to get 1 row every 10 lines to output column D, C. so that the code runs as fast as possible. Sincerely thank

VBA GET 10 TO 1.xlsm

drive.google.com

 

[alansidman]

Sub EveryTen()
Dim lr As Long, i As Long, lr2 As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("A1:B1").Copy
lr2 = Range("D" & Rows.Count).End(xlUp).Row + 1
Range("D1").PasteSpecial xlPasteValues
For i = 10 To lr Step 10
lr2 = Range("D" & Rows.Count).End(xlUp).Row + 1
Range("A" & i & ":B" & i).Copy
Range("D" & lr2).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "completed"

End Sub

 

[offthelip]

try this:

Sub test()
inarr = Range("a1:B10000")
Dim outarr(1 To 1000, 1 To 2)
indi = 1
For i = 1 To 10000 Step 10
 outarr(indi, 1) = inarr(i, 1)
 outarr(indi, 2) = inarr(i, 2)
 indi = indi + 1
Next i
Range("d1:e100") = outarr

 
End Sub

this should be much faster than looping through the workssheet

 

[Excelpromax123]

Sub EveryTen()
Dim lr As Long, i As Long, lr2 As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("A1:B1").Copy
lr2 = Range("D" & Rows.Count).End(xlUp).Row + 1
Range("D1").PasteSpecial xlPasteValues
For i = 10 To lr Step 10
lr2 = Range("D" & Rows.Count).End(xlUp).Row + 1
Range("A" & i & ":B" & i).Copy
Range("D" & lr2).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "completed"

End Sub

Thank you for your help. I tried running the code and found the wrong result. what i mean is how 10 lines get 1 line namely line (1,11,21,31,41...). Thank you for correcting the code. thank you

 

[alansidman]

corrected

Option Explicit

Sub EveryTen()
Dim lr As Long, i As Long, lr2 As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To lr Step 10
lr2 = Range("D" & Rows.Count).End(xlUp).Row + 1
Range("A" & i & ":B" & i).Copy
Range("D" & lr2).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "completed"

End Sub

 

[Georgiboy]

Here is what i was working on, very similar to @offthelip version but i had made it dynamic in regards to looking at the data, i was a bit slow to the table..:

Sub test()
    Dim iVar As Variant, oVar() As Variant, x As Long, z As Long
    
    iVar = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim oVar(UBound(iVar) / 10, 1)
    
    For x = 1 To UBound(iVar) Step 10
        oVar(z, 0) = iVar(x, 1)
        oVar(z, 1) = iVar(x, 2)
        z = z + 1
    Next x
    
    Range("D1").Resize(UBound(oVar) + 1, 2) = oVar
End Sub

 

[Excelpromax123]

corrected

Option Explicit

Sub EveryTen()
Dim lr As Long, i As Long, lr2 As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To lr Step 10
lr2 = Range("D" & Rows.Count).End(xlUp).Row + 1
Range("A" & i & ":B" & i).Copy
Range("D" & lr2).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "completed"

End Sub

Thank you. The code runs quite slow when the data is 10,000 lines, and when running the second and third times the output does not start at cell D1, Can you write the Array code to make it faster? Thank you

 

[offthelip]

Using variant arrays as in the posts by me and georgiboy will much faster usually 1000 times faster,

 

[Excelpromax123]

Here is what i was working on, very similar to @offthelip version but i had made it dynamic in regards to looking at the data, i was a bit slow to the table..:

Sub test()
    Dim iVar As Variant, oVar() As Variant, x As Long, z As Long
   
    iVar = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim oVar(UBound(iVar) / 10, 1)
   
    For x = 1 To UBound(iVar) Step 10
        oVar(z, 0) = iVar(x, 1)
        oVar(z, 1) = iVar(x, 2)
        z = z + 1
    Next x
   
    Range("D1").Resize(UBound(oVar) + 1, 2) = oVar
End Sub

Thank you. If you take 2 columns, the code runs very fast. But I want to get 4 columns data, I try to edit the Code, it gives an error. Can you help me to get the data of 4 columns or more columns. Thank you

 

[Georgiboy]

I would edit the code to something like:

Sub test()
    Dim iVar As Variant, oVar() As Variant, x As Long, z As Long
  
    iVar = Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim oVar(UBound(iVar) / 10, UBound(iVar, 2) - 1)
  
    For x = 1 To UBound(iVar) Step 10
        oVar(z, 0) = iVar(x, 1)
        oVar(z, 1) = iVar(x, 2)
        oVar(z, 2) = iVar(x, 3)
        oVar(z, 3) = iVar(x, 4)
        z = z + 1
    Next x
  
    Range("H1").Resize(UBound(oVar) + 1, UBound(oVar, 2) + 1) = oVar
End Sub

I have made the ReDim part to be dynamic to the range size 'iVar'
I have also changed the last line of code to be dynamic to the size of the output array 'oVar'