编写Excel VBA宏实现跨表数据复制、验证及目标区域动态调整（含代码排查）

核心问题 #

1. 数组长度判断错误：你初始化filteredArray时用了numRowsToPopulate作为行数，但实际筛选出的数据量可能小于这个值，代码却用UBound(filteredArray,1)作为总数据行数，导致循环逻辑错误，只填充一列就停止。
2. 缺少目标行跳过逻辑：原代码完全没实现检查Distributed工作表特定区域、跳过对应行的功能，这是你扩展需求的核心。

修正步骤 #

1. 正确统计筛选后的数据量 #

放弃用数组的UBound，改用实际填充的计数器k来记录有效数据的行数，避免空数据干扰循环。

2. 预收集允许填充的行号 #

先遍历目标区域，标记出没有特定数据的行，把这些行号存入列表，后续数据只填充到这些行里。

3. 均匀分配数据到允许的行 #

基于允许的行列表，按列循环，依次把筛选后的数据填充到可用行，直到所有数据都分配完毕。

修正后的代码 #

Sub EvenlyDistributeDataExcludeNames()
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim sourceRange As Range
    Dim filteredArray() As Variant
    Dim numRowsFiltered As Integer ' 实际筛选出的数据行数
    Dim numColumns As Integer
    Dim i As Integer, k As Integer, col As Integer, rowIdx As Integer
    Dim numRowsToPopulate As Integer
    Dim allowedRows As Collection ' 存储允许填充的行号
    Dim targetCheckRange As Range ' 需要检查的目标区域（根据你的需求修改范围）
    
    ' 初始化工作表和范围
    Set sourceSheet = ThisWorkbook.Sheets("Pending")
    Set destinationSheet = ThisWorkbook.Sheets("Distributed")
    Set sourceRange = sourceSheet.Range("A2:A100")
    numRowsToPopulate = destinationSheet.Range("R27").Value
    ' 这里修改为你需要检查的特定区域，比如假设检查B3:B11的内容是否为"跳过"
    Set targetCheckRange = destinationSheet.Range("B3:B11")
    
    ' 步骤1：收集允许填充的行号（跳过有特定数据的行）
    Set allowedRows = New Collection
    For i = 1 To targetCheckRange.Rows.Count
        ' 这里修改你的判断条件，比如目标单元格不等于"特定数据"时允许填充
        If targetCheckRange.Cells(i, 1).Value <> "特定数据" Then
            allowedRows.Add i + 2 ' 因为目标区域从第3行开始，所以行号=索引+2
        End If
    Next i
    
    ' 步骤2：筛选源数据（原逻辑保留，修正数组长度）
    ReDim filteredArray(1 To sourceRange.Rows.Count, 1 To 1)
    k = 1
    For i = 1 To sourceRange.Rows.Count
        If IsEmpty(sourceSheet.Cells(i + 1, 4)) Then
            filteredArray(k, 1) = sourceSheet.Cells(i + 1, 1).Value
            k = k + 1
            If k > allowedRows.Count Then Exit For ' 最多填充到允许的行总数
        End If
    Next i
    numRowsFiltered = k - 1 ' 实际有效数据行数
    
    ' 步骤3：均匀分配数据到允许的行
    If numRowsFiltered = 0 Or allowedRows.Count = 0 Then Exit Sub ' 无数据或无可用行直接退出
    
    numColumns = 9 ' 目标列数（C到O共9列）
    col = 3 ' 起始列C
    rowIdx = 1 ' 允许行的索引
    
    For k = 1 To numRowsFiltered
        ' 填充到当前允许的行
        destinationSheet.Cells(allowedRows(rowIdx), col).Value = filteredArray(k, 1)
        rowIdx = rowIdx + 1
        ' 当前列的允许行用完，切换到下一列
        If rowIdx > allowedRows.Count Then
            rowIdx = 1
            col = col + 1
            ' 超出目标列范围就停止（防止越界）
            If col > 3 + numColumns - 1 Then Exit For
        End If
    Next k
End Sub

关键修改说明 #

• 允许行收集：通过Collection存储所有可以填充的行号，你需要修改targetCheckRange和判断条件（<> "特定数据"）来匹配你的实际需求。
• 数据量修正：用numRowsFiltered = k - 1获取实际筛选出的有效数据行数，避免空数组元素干扰。
• 填充逻辑优化：按列循环，依次填充到允许的行，用完当前列的可用行后自动切换到下一列，确保数据均匀分布。

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