如何將其壓縮為 For 循環？

Question

在此先感謝您的幫助。 我在 VBA 方面無論如何都不是很好，我猜必須有一種方法可以節省時間/精力為此編寫代碼。 總之，我試圖讓 Sheet1.Cells(2, 1) 在 Sheet2.Cells(i, 1) 上打印，其中 i = 2 到 21，然后移動到工作表 1 中的下一行。所以，它會對 Sheet1.Cells(3, 1) 執行相同的操作以打印到 Sheet2.Cells(i, 1) ，其中 i = 22 到 41 這次。 下面是我可以使用的代碼，但我需要這樣做數千次。 有沒有辦法讓這段代碼更健壯？

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

Answer 1

使用步進和調整大小：

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

Answer 2

對您的代碼最基本的重寫是這樣的：

Sub VIN_Decode()
    For j = 0 To 4
        For i = 2 To 21
            Sheet2.Cells(20 * j + i, 1) = Sheet1.Cells(j + 2, 1)
        Next
    Next
End Sub

Answer 3

從數組中的 Sheet1 獲取源值
使目標范圍的高度保持不變
然后循環源數組

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

或者你可以使用這個公式：

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

Answer 4

用堆疊的單元格值填充堆疊的范圍

• 調整（使用）常量部分中的值。

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

單線

Sub FillStackedRangesWithStackedCellValuesTEST2()

    FillStackedRangesWithStackedCellValues _
        FirstRange:=Sheet2.Range("A2:A21"), _
        FirstCell:=Sheet1.Range("A2"), _
        StacksCount:=5
        
End Sub

Sub FillStackedRangesWithStackedCellValuesTEST3()

    FillStackedRangesWithStackedCellValues _
        Sheet2.Range("A2:A21"), Sheet1.Range("A2"), 5
        
End Sub