如何让VBA的For Next循环遍历所有IMP行而非重复首行数据？

错误原因 #

• 核心问题：每次循环调用Columns("C:C").Find(What:="IMP")时，默认从列的起始位置开始查找，因此每次都返回第一个匹配"IMP"的单元格，导致所有循环迭代都写入同一行的用户信息。
• 次要问题：代码依赖Activate和Select操作工作表，这会降低代码稳定性，且是VBA的非最优写法。

修正方案 #

使用Find配合FindNext方法遍历所有匹配"IMP"的单元格，同时直接通过工作表对象引用单元格，避免激活操作。具体逻辑：先定位第一个匹配项，再循环查找后续匹配项，同步将数据写入Averages工作表的指定行。

修正后的代码 #

Sub CopyIMPData()
    Dim wsNames As Worksheet
    Dim wsAverages As Worksheet
    Dim IMPRows As Long
    Dim rngFirstIMP As Range
    Dim rngNextIMP As Range
    Dim writeRow As Long
    
    ' 直接绑定工作表对象，避免Activate/Select操作
    Set wsNames = ThisWorkbook.Worksheets("Names")
    Set wsAverages = ThisWorkbook.Worksheets("Averages")
    
    ' 统计C列中IMP的行数
    IMPRows = Application.WorksheetFunction.CountIf(wsNames.Columns("C:C"), "IMP")
    ' EXPRows 若后续需要可保留，此处暂注释
    ' EXPRows = Application.WorksheetFunction.CountIf(wsNames.Columns("C:C"), "EXP")
    
    ' 设置Averages工作表的写入起始行
    writeRow = 6
    
    ' 找到第一个标记为IMP的单元格
    Set rngFirstIMP = wsNames.Columns("C:C").Find(What:="IMP", MatchCase:=True)
    
    If Not rngFirstIMP Is Nothing Then
        Set rngNextIMP = rngFirstIMP
        ' 遍历所有IMP行
        Do
            ' 将对应行的首字母和用户名写入目标工作表
            wsAverages.Cells(writeRow, 1).Value = rngNextIMP.Offset(0, -2).Value
            wsAverages.Cells(writeRow, 2).Value = rngNextIMP.Offset(0, -1).Value
            
            ' 移动到下一个写入行
            writeRow = writeRow + 1
            
            ' 查找下一个IMP单元格
            Set rngNextIMP = wsNames.Columns("C:C").FindNext(rngNextIMP)
            
            ' 终止循环：当FindNext回到第一个匹配单元格时停止，避免无限循环
        Loop While Not rngNextIMP Is Nothing And rngNextIMP.Address <> rngFirstIMP.Address
    End If
End Sub

代码说明 #

• 用工作表变量直接绑定目标表，避免激活操作，提升代码稳定性和执行效率
• Find+FindNext组合确保遍历所有匹配"IMP"的行，不会遗漏或重复读取同一行
• 通过writeRow变量精准控制写入位置，从第6行开始依次向下填充
• 加入循环终止条件，防止因FindNext循环遍历导致的无限循环

内容的提问来源于stack exchange，提问作者One foot in the Grave