我怎样才能把它压缩成一个 For 循环？

Posted 2023-03-28

【中文标题】我怎样才能把它压缩成一个 For 循环？

【英文标题】：How can I condense this into a For Loop?

【发布时间】：2021-12-13 20:58:21

【问题描述】：

提前感谢您的帮助。我在 VBA 上无论如何都不是很好，我猜必须有一种方法可以节省为此编写代码的时间/精力。总之，我试图让 Sheet1.Cells(2, 1) 在 i = 2 到 21 的 Sheet2.Cells(i, 1) 上打印，然后移动到工作表 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

【问题讨论】：

你有什么版本的 Excel？这可能很容易通过公式来实现。

【参考方案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

【讨论】：

完美！非常感谢！

【参考方案2】：

从数组中的 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(,) )

【参考方案3】：

用堆叠的单元格值填充堆叠的范围

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

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

【参考方案4】：

你的代码最基本的重写是这样的：

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

【讨论】：

很好，但是 5 应该是 4。

@VBasic2008 - 谢谢！不错的选择。