How can I condense this into a For Loop?-CodePudding

Thanks in advance for the help. I'm not great by any means at VBA, and I'm guessing there has to be a way to save time/effort writing code for this. In summary, I'm trying to get Sheet1.Cells(2, 1) to print on Sheet2.Cells(i, 1) where i = 2 to 21, and then move to the next row in sheet 1. So, it would do the same thing for Sheet1.Cells(3, 1) to print to Sheet2.Cells(i, 1) where i = 22 to 41 this time. Below is the code that I have that works, but I need to do this thousands of times. Is there any way to make this code more robust?

Sub VIN_Decode()

For i = 2 To 21
Sheet2.Cells(i, 1) = Sheet1.Cells(2, 1)
Next
For i = 22 To 41
Sheet2.Cells(i, 1) = Sheet1.Cells(3, 1)
Next
For i = 42 To 61
Sheet2.Cells(i, 1) = Sheet1.Cells(4, 1)
Next
For i = 62 To 81
Sheet2.Cells(i, 1) = Sheet1.Cells(5, 1)
Next
For i = 82 To 101
Sheet2.Cells(i, 1) = Sheet1.Cells(6, 1)
Next

End Sub

CodePudding user response：

Use Step and Resize:

Sub VIN_Decode()
    For i = 2 To 82 Step 20
        Sheet2.Cells(i, 1).Resize(20, 1).Value = Sheet1.Cells((i - 2) / 20   2, 1).Value
    Next
End Sub

CodePudding user response：

Get the source values from Sheet1 in an array
Have the Height of the Target Ranges in a constant
Then loop the Source Array

Sub VIN_Decode()
Const kHeight As Byte = 20
Dim aSource As Variant
Dim lRow As Long
Dim vItem As Variant

    aSource = Sheet1.Cells(2, 1).Resize(5)
    With Sheet2
        lRow = 2    'Initial Row
        For Each vItem In aSource
            Debug.Print vItem
            .Cells(lRow, 1).Resize(kHeight).Value = vItem
            lRow = lRow   kHeight
        Next
    End With
    
    End Sub

Or you can use this formula:

= IFERROR( INDEX( Sheet1!A:A, LOOKUP(ROW(), {2,2;22,3;42,4;62,5;82,6;102,""}) ), TEXT(,) )

CodePudding user response：

Fill Stacked Ranges With Stacked Cell Values

Adjust (play with) the values in the constants section.

Option Explicit

Sub FillStackedRangesWithStackedCellValuesTEST()

    Const dfrgAddress As String = "A2:A21"
    Const sfCellAddress As String = "A2"
    Const StacksCount As Long = 5
    
    Dim sfCell As Range: Set sfCell = Sheet1.Range(sfCellAddress)
    Dim dfrg As Range: Set dfrg = Sheet2.Range(dfrgAddress)
    
    FillStackedRangesWithStackedCellValues dfrg, sfCell, StacksCount
        
End Sub

Sub FillStackedRangesWithStackedCellValues( _
        ByVal FirstRange As Range, _
        ByVal FirstCell As Range, _
        ByVal StacksCount As Long)
    Const ProcName As String = "FillStackedRangesWithStackedCellValues"
    On Error GoTo ClearError
     
    Dim sCell As Range: Set sCell = FirstCell.Cells(1) ' ensure one cell
    Dim drg As Range: Set drg = FirstRange
    Dim drCount As Long: drCount = drg.Rows.Count
    
    Dim Stack As Long
    
    For Stack = 1 To StacksCount
        drg.Value = sCell.Value
        Set drg = drg.Offset(drCount)
        Set sCell = sCell.Offset(1)
    Next Stack
        
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub