VBA宏重复运行数据覆盖及DSCR提取不全问题求助

问题1：多次运行宏覆盖原有数据 #

原因：每次运行都从C1写入表头、从C2开始粘贴数据，未判断目标表已有数据的位置，导致覆盖。
解决方法：

• 先检查目标工作表是否已存在表头，不存在则一次性写入所有表头；
• 找到目标表中已有数据的最后一行，从该行的下一行开始粘贴新数据，实现追加。

问题2：无法提取「DSCR」的第二个实例 #

原因：

• 数组索引从0开始，DSCR是数组最后一个元素，索引为16，原代码判断i=17永远不会触发；
• FindNext使用前未记录初始查找地址，存在循环风险。
  解决方法：
• 针对数组最后一个元素（DSCR），先找到第一个实例，再调用FindNext定位第二个实例；
• 记录初始查找地址，避免FindNext循环回到第一个实例。

修改后的完整代码 #

Option Explicit

Sub Extract()
    Dim arr, i As Long, f As Range, cPaste As Range, col As Long
    Dim wbPaste As Workbook, wsPaste As Worksheet, wsSrc As Worksheet, wSrc As Workbook
    Dim lastRow As Long, firstFoundAddr As String
    
    arr = Array("DSCR Analysis", "Commercial Income", "Rental Income", "Other Income", _
            "Total All Income", "Rental Vacancy (%)", "Rental Vacancy ($)", _
            "Commercial Vacancy (%)", "Concessions/Bad Debt (%)", "Concessions/Bad Debt ($)", _
            "Effective Gross Income", "Total Expenses", "NOI", "Facility A Contractual Rate", _
            "MBI Debt Service", "Excess Cash Flow", "DSCR")
    
    Set wSrc = ActiveWorkbook
    Set wsSrc = wSrc.Sheets("MBI DSCR")
    Set wbPaste = Workbooks.Open("C:\Users\bbarineau\OneDrive - Merchants Bancorp\Desktop\LBM_DSCT_DataLake.xlsm")
    Set wsPaste = wbPaste.Sheets(1)
    
    ' 获取MBI所在列
    col = wsSrc.Columns.Find(What:="MBI", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Column
    
    ' 处理目标表表头与数据追加位置
    With wsPaste
        ' 检查是否已有表头，无则写入
        If .Range("C1").Value <> arr(LBound(arr)) Then
            Set cPaste = .Range("C1")
            ' 批量写入指标表头
            For i = LBound(arr) To UBound(arr)
                cPaste.Value = arr(i)
                Set cPaste = cPaste.Offset(0, 1)
            Next i
            ' 写入辅助列表头
            .Range("A1").Value = "Date Added"
            .Range("B1").Value = "Name"
            ' 首次数据粘贴起始行
            lastRow = 2
        Else
            ' 找到已有数据的最后一行（以C列为准）
            lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
        End If
    End With
    
    ' 设置当前批次数据的粘贴起始位置
    Set cPaste = wsPaste.Cells(lastRow, "C")
    
    For i = LBound(arr) To UBound(arr)
        Set f = wsSrc.Columns(col).Find(What:=arr(i), LookIn:=xlValues, _
                                    LookAt:=xlPart, MatchCase:=False)
        
        ' 处理DSCR的第二个实例
        If i = UBound(arr) And Not f Is Nothing Then
            firstFoundAddr = f.Address ' 记录第一个实例地址，防止循环
            Set f = wsSrc.Columns(col).FindNext(f)
            ' 确保找到的是第二个实例而非回到初始位置
            If f.Address = firstFoundAddr Then Set f = Nothing
        End If
        
        If Not f Is Nothing Then
            f.Offset(0, 1).Resize(1, 6).Copy
            cPaste.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                             Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End If
        
        Set cPaste = cPaste.Offset(0, 1) ' 切换到下一个指标列
    Next i
    
    ' 填充辅助列数据
    With wsPaste
        .Range(.Cells(lastRow, "A"), .Cells(lastRow + 5, "A")).Value = Date
        .Range(.Cells(lastRow, "B"), .Cells(lastRow + 5, "B")).Value = wSrc.Name
        .Rows.AutoFit
        .Columns.AutoFit
    End With
    
    wbPaste.Close SaveChanges:=True
    Application.CutCopyMode = False ' 清除复制状态
End Sub

关键修改点说明 #

1. 数据追加逻辑：
   • 通过C1的值判断是否为首次运行，避免重复写入表头；
   • 利用Cells(.Rows.Count, "C").End(xlUp).Row精准定位已有数据的末尾，确保新数据追加在下方。
2. DSCR实例提取：
   • 用UBound(arr)动态定位数组最后一个元素，避免硬编码索引；
   • 记录初始查找地址，防止FindNext无限循环。
3. 辅助列完善：自动填充当前日期和源工作簿名称，覆盖每次运行生成的6行数据；
4. 状态清理：添加Application.CutCopyMode = False，避免Excel保留复制选中状态。

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