如何用For循环遍历B列所有"MI (D)"并执行对应VBA代码？

需求：在B列中查找所有值为"MI (D)"的单元格，对每个匹配项执行对应处理逻辑。原代码仅能处理第一个匹配项，需修改为遍历所有匹配项。

原VBA代码 #

Dim Rng As Range
Dim cell As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
Set Rng = Range("B:B").Find("MI (D)")

For Each cell In Rng
    
If Not Rng Is Nothing Then
    Rng.Select
End If
    
ActiveCell.Offset(0, 1).Select
Range(ActiveCell, ActiveCell.Offset(0, 1)).Select
Selection.Copy
    
    'For Each cell In ws.Columns(3).Cells
    '    If IsEmpty(cell) = True Then cell.Select: Exit For
    'Next cell
    
Dim LastRow As Long

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(LastRow, 3).Offset(1, 0).Select
    
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(-3, 0).Select

ActiveCell = ActiveCell - 1
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell + 25

ActiveCell.Offset(1, -1).Select
ActiveCell = ActiveCell - 1
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell + 25
    
ActiveCell.Offset(1, -1).Select
ActiveCell = ActiveCell - 11
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell + 50

ActiveCell.Offset(1, -1).Select
ActiveCell = ActiveCell - 11
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell + 50


Rng.Select
ActiveCell.Offset(0, -1).Select
Selection.Copy

'For Each cell In ws.Columns(1).Cells
'    If IsEmpty(cell) = True Then cell.Select: Exit For
'Next cell

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(LastRow, 1).Offset(1, 0).Select

Selection.PasteSpecial paste:=xlPasteValues
ActiveCell.Offset(1, 1).Select
Selection.PasteSpecial paste:=xlPasteValues
ActiveCell.Offset(1, -1).Select
Selection.PasteSpecial paste:=xlPasteValues
ActiveCell.Offset(1, 1).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(-3, 0).Select

Selection = "ON (D)"
Selection.Copy

ActiveCell.Offset(1, -1).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 1).Select
Selection = "ON (I)"
Selection.Copy
ActiveCell.Offset(1, -1).Select
Selection.PasteSpecial paste:=xlPasteValues

Next cell
End sub

修改后的代码 #

Sub ProcessAllMIDEntries()
    Dim ws As Worksheet
    Dim findRng As Range
    Dim firstFoundAddr As String
    Dim lastRow As Long
    Dim pasteStartCell As Range
    
    Set ws = ActiveSheet
    
    ' 查找第一个匹配项
    Set findRng = ws.Range("B:B").Find(What:="MI (D)", LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not findRng Is Nothing Then
        firstFoundAddr = findRng.Address ' 记录第一个匹配地址，防止循环无限
        
        Do
            ' --- 处理当前匹配项的逻辑开始 ---
            ' 复制C、D列的值到最后一行下方的C列开始位置
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            Set pasteStartCell = ws.Cells(lastRow + 1, 3)
            
            ' 直接赋值替代复制粘贴，更高效
            pasteStartCell.Value = findRng.Offset(0, 1).Value
            pasteStartCell.Offset(1, 0).Value = findRng.Offset(0, 1).Value
            pasteStartCell.Offset(2, 0).Value = findRng.Offset(0, 1).Value
            pasteStartCell.Offset(3, 0).Value = findRng.Offset(0, 1).Value
            
            pasteStartCell.Offset(0, 1).Value = findRng.Offset(0, 2).Value
            pasteStartCell.Offset(1, 1).Value = findRng.Offset(0, 2).Value
            pasteStartCell.Offset(2, 1).Value = findRng.Offset(0, 2).Value
            pasteStartCell.Offset(3, 1).Value = findRng.Offset(0, 2).Value
            
            ' 修改数值
            pasteStartCell.Value = pasteStartCell.Value - 1
            pasteStartCell.Offset(0, 1).Value = pasteStartCell.Offset(0, 1).Value + 25
            
            pasteStartCell.Offset(1, 0).Value = pasteStartCell.Offset(1, 0).Value - 1
            pasteStartCell.Offset(1, 1).Value = pasteStartCell.Offset(1, 1).Value + 25
            
            pasteStartCell.Offset(2, 0).Value = pasteStartCell.Offset(2, 0).Value - 11
            pasteStartCell.Offset(2, 1).Value = pasteStartCell.Offset(2, 1).Value + 50
            
            pasteStartCell.Offset(3, 0).Value = pasteStartCell.Offset(3, 0).Value - 11
            pasteStartCell.Offset(3, 1).Value = pasteStartCell.Offset(3, 1).Value + 50
            
            ' 处理A列复制和修改
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            Set pasteStartCell = ws.Cells(lastRow + 1, 1)
            
            pasteStartCell.Value = findRng.Offset(0, -1).Value
            pasteStartCell.Offset(1, 1).Value = findRng.Offset(0, -1).Value
            pasteStartCell.Offset(2, 0).Value = findRng.Offset(0, -1).Value
            pasteStartCell.Offset(3, 1).Value = findRng.Offset(0, -1).Value
            
            ' 设置状态值
            pasteStartCell.Offset(0, 1).Value = "ON (D)"
            pasteStartCell.Offset(1, 0).Value = "ON (D)"
            
            pasteStartCell.Offset(2, 1).Value = "ON (I)"
            pasteStartCell.Offset(3, 0).Value = "ON (I)"
            ' --- 处理当前匹配项的逻辑结束 ---
            
            ' 查找下一个匹配项
            Set findRng = ws.Range("B:B").FindNext(findRng)
            
            ' 如果回到第一个匹配地址，退出循环
        Loop While Not findRng Is Nothing And findRng.Address <> firstFoundAddr
    End If
End Sub

关键修改点 #

• 遍历所有匹配项：改用Find + FindNext的循环结构，通过记录第一个匹配的地址避免无限循环，确保遍历B列中所有"MI (D)"单元格
• 移除Select/Selection：原代码大量使用选择单元格的操作，不仅低效还容易出错，修改为直接通过单元格对象操作值，稳定性和效率大幅提升
• 简化复制粘贴：将多次复制粘贴操作改为直接赋值，逻辑更清晰，执行更快
• 统一变量作用域：调整变量声明位置，避免重复声明，代码结构更规范

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