VBA开发技术问询：内循环后如何新建数组列并实现周期数据的列拆分

我来帮你搞定这两个VBA数组相关的问题，咱们一步步拆解解决：

你的核心需求是处理时间序列数据，找出低于阈值的区间，记录每个区间从最小值到恢复的天数，以及区间的日期范围。目前卡在两个点：内循环后无法向数组新列添加数据，以及天数和日期区间在数组里混存，无法拆分到不同列。

问题1：内循环后向新数组列添加数据 #

原代码里用一维数组varMyArray存储结果，每次循环列的时候会覆盖之前的数据。要实现每列数据对应结果数组的一列，我们需要用二维数组来存储，每处理完一列数据，就把该列的结果写入最终数组的对应列组（比如第1列数据的结果占最终数组的第1、2列，第2列数据的结果占第3、4列，以此类推）。

问题2：拆分天数和日期区间到不同列 #

原代码把天数和日期区间交替存入Collection，导致数组结构是[天数1, 日期1, 天数2, 日期2...]的一维结构。我们需要把每个周期的两个值放在同一行的不同列，也就是数组变成[[天数1, 日期1], [天数2, 日期2], ...]的二维结构，这样导出到Excel时直接按行/列写入即可。

修改后的完整代码 #

我优化了原代码的不良习惯（比如去掉Select操作，直接引用Range），同时解决了你的两个核心问题：

Sub AnalyzeThresholdData()
    Dim ws As Worksheet
    Dim varDates As Variant, varAll As Variant
    Dim dblDDLim As Double
    Dim i As Long, j As Long
    Dim lngCounter As Long, lngPerCounter As Long
    Dim dtTemp() As Date, varTemp() As Double
    Dim colResults As Collection ' 存储每个周期的(天数, 日期区间)对
    Dim varColumnResults() As Variant ' 当前列的结果（二维：行=周期，列=天数/日期）
    Dim varFinalResults() As Variant ' 最终总结果数组
    Dim intMin As Long
    Dim lngPerLen As Long
    Dim strRecLen As String
    
    ' 绑定工作表，建议替换成具体工作表名，避免依赖激活表
    Set ws = ThisWorkbook.Worksheets("你的工作表名")
    dblDDLim = ws.Range("BD8").Value ' 读取阈值
    
    ' 读取日期列数据（BB10开始向下到最后一行）
    varDates = ws.Range(ws.Range("BB10"), ws.Range("BB10").End(xlDown)).Value
    ' 读取5列百分比数据（BC10开始向右向下到最后一行）
    varAll = ws.Range(ws.Range("BC10"), ws.Range("BC10").End(xlToRight).End(xlDown)).Value
    
    ' 初始化最终结果数组，预留足够列数（每原数据列对应2列结果）
    ReDim varFinalResults(1 To 1000, 1 To UBound(varAll, 2) * 2)
    
    For i = LBound(varAll, 2) To UBound(varAll, 2)
        Set colResults = New Collection
        lngCounter = 0
        lngPerCounter = 0
        Erase dtTemp
        Erase varTemp
        
        For j = LBound(varAll, 1) To UBound(varAll, 1)
            If Not IsEmpty(varAll(j, i)) Then
                ' 扩展临时数组存储当前区间的日期和数值
                lngCounter = lngCounter + 1
                ReDim Preserve dtTemp(1 To lngCounter)
                ReDim Preserve varTemp(1 To lngCounter)
                dtTemp(lngCounter) = varDates(j, 1)
                varTemp(lngCounter) = varAll(j, i)
            Else
                ' 遇到空单元格，检查当前区间是否符合阈值条件
                If lngCounter > 0 Then
                    If WorksheetFunction.Min(varTemp) < dblDDLim Then
                        ' 找到最小值的1-based索引
                        intMin = IsInArray_Index_oneDim(WorksheetFunction.Min(varTemp), varTemp)
                        lngPerLen = UBound(varTemp) - intMin + 1 ' 计算天数
                        ' 格式化日期区间，让输出更规范
                        strRecLen = Format(dtTemp(intMin), "yyyy-mm-dd") & " - " & Format(dtTemp(UBound(dtTemp)), "yyyy-mm-dd")
                        
                        ' 将天数和日期区间作为一组存入Collection
                        colResults.Add Array(lngPerLen, strRecLen)
                        lngPerCounter = lngPerCounter + 1
                    End If
                End If
                ' 重置计数器和临时数组
                lngCounter = 0
                Erase dtTemp
                Erase varTemp
            End If
        Next j
        
        ' 处理循环结束后可能遗留的最后一个非空区间
        If lngCounter > 0 Then
            If WorksheetFunction.Min(varTemp) < dblDDLim Then
                intMin = IsInArray_Index_oneDim(WorksheetFunction.Min(varTemp), varTemp)
                lngPerLen = UBound(varTemp) - intMin + 1
                strRecLen = Format(dtTemp(intMin), "yyyy-mm-dd") & " - " & Format(dtTemp(UBound(dtTemp)), "yyyy-mm-dd")
                colResults.Add Array(lngPerLen, strRecLen)
                lngPerCounter = lngPerCounter + 1
            End If
        End If
        
        ' 将当前列的结果转换为二维数组，写入最终结果的对应位置
        If lngPerCounter > 0 Then
            ReDim varColumnResults(1 To lngPerCounter, 1 To 2)
            For j = 1 To lngPerCounter
                varColumnResults(j, 1) = colResults(j)(0) ' 天数列
                varColumnResults(j, 2) = colResults(j)(1) ' 日期区间列
            Next j
            
            ' 写入最终数组：第i列原数据的结果占第(2i-1)和(2i)列
            For j = 1 To lngPerCounter
                varFinalResults(j, 2 * i - 1) = varColumnResults(j, 1)
                varFinalResults(j, 2 * i) = varColumnResults(j, 2)
            Next j
            
            ' 动态调整最终数组的行数，避免浪费空间
            If lngPerCounter > UBound(varFinalResults, 1) Then
                ReDim Preserve varFinalResults(1 To lngPerCounter, 1 To UBound(varFinalResults, 2))
            End If
        End If
    Next i
    
    ' 将结果导出到Excel（从BE10开始写入）
    ws.Range("BE10").Resize(UBound(varFinalResults, 1), UBound(varFinalResults, 2)).Value = varFinalResults
    
    ' 释放对象
    Set colResults = Nothing
    Set ws = Nothing
End Sub

Public Function IsInArray_Index_oneDim(findVal As Variant, arr As Variant) As Long
    ' 补充实现：返回值在一维数组中的1-based索引，没找到返回-1
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If arr(i) = findVal Then
            IsInArray_Index_oneDim = i
            Exit Function
        End If
    Next i
    IsInArray_Index_oneDim = -1
End Function

核心修改说明 #

1. 解决列添加问题：

   • 用varFinalResults二维数组存储所有列的结果，每原数据列对应2列结果（天数+日期区间）
   • 每处理完一列数据，就把该列的结果写入最终数组的对应列组，不会覆盖之前的数据

2. 拆分数据到不同列：

   • 每个周期的天数和日期区间作为一个数组对存入Collection
   • 转换为二维数组时，直接把天数放在第一列，日期区间放在第二列，导出到Excel时自然拆分到不同列

3. 其他优化：

   • 去掉了所有Select操作，直接通过工作表对象引用Range，避免依赖激活单元格
   • 处理了循环结束后可能遗留的最后一个非空区间
   • 添加了日期格式化，让区间字符串更规范

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