VBA如何实现输入数值后输出0到该数值区间内偶数重复两次的数组

核心调整逻辑 #

新增独立的列位置计数器，遍历0到输入值的所有数字时，判断数字奇偶性：偶数连续写入2次，奇数写入1次，每次写入后列位置自增1即可。

修改后可直接运行的代码 #

Sub Macro3()
    Dim inputVal As Long
    Dim currentNum As Long
    Dim colOffset As Long
    ' 读取Sheet1的B1单元格输入的最大值
    inputVal = Worksheets("Sheet1").Cells(1, 2).Value
    ' 初始化输出起始列：默认从第2列（B列）开始输出，可按需修改
    colOffset = 2
    For currentNum = 0 To inputVal
        ' 写入当前数字
        Cells(2, colOffset).Value = currentNum
        colOffset = colOffset + 1
        ' 偶数额外再写入一次
        If currentNum Mod 2 = 0 Then
            Cells(2, colOffset).Value = currentNum
            colOffset = colOffset + 1
        End If
    Next
End Sub

优化版本（数组存储后一次性写入，性能更好，适合大数值输入场景） #

Sub Macro3_Optimized()
    Dim inputVal As Long
    Dim resultArr As Variant
    Dim currentNum As Long
    Dim arrIndex As Long
    inputVal = Worksheets("Sheet1").Cells(1, 2).Value
    ' 预计算数组长度：偶数数量*2 + 奇数数量*1 = (inputVal\2 +1)*2 + (inputVal - inputVal\2)
    ReDim resultArr(1 To (inputVal \ 2 + 1) * 2 + (inputVal - inputVal \ 2))
    arrIndex = 1
    For currentNum = 0 To inputVal
        resultArr(arrIndex) = currentNum
        arrIndex = arrIndex + 1
        If currentNum Mod 2 = 0 Then
            resultArr(arrIndex) = currentNum
            arrIndex = arrIndex + 1
        End If
    Next
    ' 一次性输出到第2行，从B列开始的区域
    Cells(2, 2).Resize(1, UBound(resultArr)).Value = resultArr
End Sub

内容的提问来源于stack exchange，提问作者Mabrook Sattar