基于另一工作表列指定范围值更新目标行单元格的VBA问题

你的代码存在两个核心问题：

• 值被覆盖：每次找到符合条件的数据时，都写入同一个单元格（或整列），新值会直接替换旧值，最终只保留最后一个符合条件的结果。
• 按列填充：目标区域指定的是列（如A:A）或单个单元格，没有按行方向依次写入。

修正后的代码 #

Sub FilterAndFillRow()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim currentCol As Integer
    Dim i As Long
    
    ' 定义工作表对象
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set targetSheet = ThisWorkbook.Sheets("Sheet2")
    
    ' 初始化目标列位置（示例从第3列C开始）
    currentCol = 3
    ' 获取Sheet1 D列最后一行有数据的行号
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    
    ' 遍历Sheet1 D列的有效数据行
    For i = 1 To lastRow
        ' 判断数值是否在10-100之间（需要包含边界的话，把>改成>=、<改成<=）
        If IsNumeric(sourceSheet.Cells(i, "D").Value) And _
           sourceSheet.Cells(i, "D").Value > 10 And _
           sourceSheet.Cells(i, "D").Value < 100 Then
            ' 写入Sheet2的第20行，当前列位置
            targetSheet.Cells(20, currentCol).Value = sourceSheet.Cells(i, "D").Value
            ' 列位置后移，避免覆盖
            currentCol = currentCol + 1
        End If
    Next i
End Sub

代码说明 #

• 避免无效遍历：通过lastRow获取D列最后一行数据，只遍历有内容的行，提升运行效率。
• 跟踪目标位置：用currentCol变量记录当前要写入的列，每写入一个值就后移一列，彻底解决覆盖问题。
• 实现单行填充：固定写入行号（20），动态调整列号，确保结果在Sheet2第20行连续排列，无空白单元格。
• 增加数值校验：加入IsNumeric检查，避免非数值内容引发运行错误。

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