Excel VBA问题：循环复制指定区间数据时重复复制首个范围

问题场景 #

我是VBA及编程新手，对基础操作尚不熟悉。现有Excel工作表“BS growth”包含十多家企业的资产负债表，需根据D列资产名称，复制“Securities”与“Derivatives”之间的行数据。目前已成功复制第一组区间的数据，但循环执行时始终重复复制首个范围，尝试过为rngA添加变量，寻求解决办法。

原代码如下：

Sub ChartReference2()
    Dim findrow As Long
    Dim findrow2 As Long
    Dim rngA As Range
    
    For Each cell In ActiveWorkbook.Worksheets("BS growth").Range("A:A")
        If cell.Value = "Asset" Then
            Worksheets("BS growth").Activate
            findrow = Range("D:D").Find("Securities", Range("D3")).Row
            findrow2 = Range("D:D").Find("Derivatives", Range("D" & findrow)).Row
            Range("D" & findrow & ":D" & findrow2, Selection.End(xlToRight)).Select
            Selection.Copy
        End If
    Next cell
End Sub

问题原因 #

1. Find起始位置固定：每次查找Securities都从D3开始，导致永远只找到第一个匹配项，无法定位到当前企业区块内的目标行。
2. 遍历整列效率低：循环遍历A列所有单元格（包括空白行），浪费资源且容易触发不必要的判断。
3. 依赖Select/Selection：激活工作表、选中单元格的操作不仅效率低，还容易因用户操作或工作表切换导致代码异常。

修正后的代码 #

Sub CopySecuritiesToDerivatives()
    Dim ws As Worksheet
    Dim assetCell As Range
    Dim startSearchRange As Range
    Dim secRow As Long, derivRow As Long
    Dim copyRange As Range
    Dim pasteRow As Long ' 定义粘贴起始行，可根据需求修改
    
    ' 初始化工作表对象，避免使用Activate
    Set ws = ThisWorkbook.Worksheets("BS growth")
    pasteRow = 1 ' 假设粘贴到当前工作表第一行，自行调整目标位置
    
    ' 只查找A列中值为"Asset"的单元格，避免遍历整列
    Set assetCell = ws.Range("A:A").Find(What:="Asset", LookAt:=xlWhole, MatchCase:=False)
    
    Do While Not assetCell Is Nothing
        ' 从当前Asset单元格的下一行开始查找Securities，限定在当前企业区块内
        Set startSearchRange = ws.Range("D" & assetCell.Row + 1)
        secRow = ws.Range("D:D").Find(What:="Securities", After:=startSearchRange, LookAt:=xlWhole, MatchCase:=False).Row
        
        ' 从Securities行开始查找Derivatives
        derivRow = ws.Range("D:D").Find(What:="Derivatives", After:=ws.Range("D" & secRow), LookAt:=xlWhole, MatchCase:=False).Row
        
        ' 确定要复制的范围（从D列到当前行最后一个有数据的列）
        Set copyRange = ws.Range(ws.Cells(secRow, "D"), ws.Cells(derivRow, ws.Cells(secRow, ws.Columns.Count).End(xlToLeft).Column))
        
        ' 直接复制粘贴，无需Select操作
        copyRange.Copy Destination:=ws.Cells(pasteRow, "F") ' 假设粘贴到F列，自行调整目标位置
        pasteRow = pasteRow + copyRange.Rows.Count + 1 ' 粘贴后换行，避免覆盖
        
        ' 查找下一个Asset单元格，避免重复处理同一行
        Set assetCell = ws.Range("A:A").FindNext(After:=assetCell)
        
        ' 防止无限循环：当回到第一个Asset单元格时退出
        If assetCell.Row <= startSearchRange.Row - 1 Then Exit Do
    Loop
End Sub

关键说明 #

• 精准定位区块：通过FindNext遍历所有"Asset"单元格，每次从当前Asset行的下一行开始查找目标，确保只处理当前企业的资产负债表区间。
• 取消Select操作：直接使用Range对象完成复制粘贴，提升代码稳定性和运行效率。
• 限定匹配规则：添加LookAt:=xlWhole确保只匹配完全相同的单元格内容，避免部分匹配导致的错误。
• 防止死循环：在循环末尾判断是否回到起始位置，避免因FindNext循环遍历同一单元格导致无限循环。

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