Excel VBA实现跨工作簿按账号筛选复制指定列及宏报错修复

• 源工作簿（Workbook 1）存储当月账户下全部用户的交易明细数据，其中E列为账号字段，存储格式为-xxxxx；目标工作簿（Workbook 2）为源工作簿中每个唯一账号单独创建了工作表，各工作表B3单元格存储对应账号，格式为xxxxx，无源数据中的前导负号。
• 需开发VBA宏实现以下自动化流程：
  1. 运行宏后首先弹窗提示用户选择源数据工作簿，适配每月源文件名称、路径变动的场景
  2. 弹窗提示选择筛选所用的账号值，支持手动点选或自动读取当前活动工作表B3单元格的账号值
  3. 自动在源工作簿的交易明细工作表中按指定账号筛选数据，仅提取筛选结果中A列（日期）、C列（描述）、F列（金额）的内容，复制到当前活动工作表，粘贴起始位置为A7单元格，源A/C/F列分别对应粘贴到目标表的A/B/C列
  4. 粘贴完成后自动执行负数处理逻辑，对粘贴到C列的金额数据执行操作，删除所有金额为负数的整行记录
  5. 支持切换到其他账号工作表后重复运行宏，完成所有账号的数据提取

目前已编写部分Copy_data()复制宏代码，存在以下问题：

• 无法实现源工作簿的用户交互选择
• AutoFilter筛选、指定多列复制、目标粘贴位置定位逻辑报错，如定位粘贴位置时出现expected array编译错误，Intersect实现指定列复制的逻辑无法正常运行
• 负数删除Deleter()宏已编写完成，但需要手动选择范围，未整合到自动化流程中

原有复制功能代码 #

Sub Copy_data()

    Application.ScreenUpdating = False

    Dim UserRange As Range
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim UserAcc As Range
    Dim LastRow As Long
    
    Set wb1 = Workbooks("Fresh AMEX May 24- June 22.xlsx") 'source book, can't figure out how to make this user input. inputbox?'
    Set wb2 = ThisWorkbook
    Set ws1 = Workbooks("Fresh AMEX May 24- June 22.xlsx").Sheets("Transaction Details") 'assuming the worksheet can just be selected and the first workbook selection can be omitted'
    Set ws2 = ThisWorkbook.Sheets("Test1")
    
    'user input to select account number for criteria'
    On Error Resume Next
    Set UserAcc = Application.InputBox(Prompt:="Select an ACCOUNT NUMBER", Title:="Select an ACCOUNT NUMBER", Default:=ActiveCell.Address, Type:=8)
    If UserAcc Is Nothing Then Exit Sub
    On Error GoTo 0

    With ws1
        LastRow = Cells(Rows.Count, "E").End(xlUp).Row
        ws1.Range("A1:0" & LastRow).AutoFilter Field:=5, Criteria1:="UserAcc"
        Intersect(.Offset(1), .Parent.Range("A:A,C:C,F:F")).Copy 'found this online that is supposed to only copy the desired columns, but can't get ti to work'
        
        With ws2.Range("A" & LastRow(ws2) + 1) 'also get a compile error here at LastRow if I omit the abover Intersect function. I get "expected array" as the error.
            .PasteSpecial xlPasteValues
        End With
    End With
End Sub

原有负数删除功能代码 #

Sub Deleter()
    Dim xRg As Range
    Dim xCell As Range
    Dim xTxt As String
    Dim i As Long
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
Sel:
    Set xRg = Nothing
    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Areas.Count > 1 Then
        MsgBox "does not support multiple selections, please select again", vbInformation, "Kutools for Excel"
        GoTo Sel
    End If
    If xRg.Columns.Count > 1 Then
        MsgBox "does not support multiple columns, please select again", vbInformation, "Kutools for Excel"
        GoTo Sel
    End If
    For i = xRg.Rows.Count To 1 Step -1
        If xRg.Cells(i) < 0 Then xRg.Cells(i).EntireRow.Delete
    Next
End Sub

核心修正点：

• 新增文件选择弹窗，支持用户手动选取任意路径下的源交易明细文件
• 账号选择默认读取当前活动表B3单元格值，同时支持手动点选其他单元格
• 自动给筛选账号补全源表要求的前导负号，匹配源表E列存储格式
• 修复原有筛选范围拼写错误、变量误用为数组的编译问题，调整可见区域多列复制逻辑
• 固定粘贴起始位置为A7，粘贴前自动清空旧数据避免内容残留
• 整合负数行删除逻辑，粘贴完成后自动处理C列金额，无需手动选择范围
• 操作完成后自动关闭源工作簿，恢复Excel默认设置

Sub Copy_data()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim accCell As Range
    Dim copyRng As Range
    Dim accNum As String
    Dim sourcePath As Variant
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim i As Long
    
    ' 弹窗选择源数据工作簿
    sourcePath = Application.GetOpenFilename( _
        FileFilter:="Excel文件(*.xlsx;*.xls;*.xlsm),*.xlsx;*.xls;*.xlsm", _
        Title:="选择当月交易明细源工作簿")
    If sourcePath = False Then
        MsgBox "未选择源工作簿，程序退出"
        GoTo ResetSetting
    End If
    Set wbSource = Workbooks.Open(Filename:=sourcePath, ReadOnly:=True)
    
    ' 校验源工作表是否存在
    On Error Resume Next
    Set wsSource = wbSource.Sheets("Transaction Details")
    On Error GoTo 0
    If wsSource Is Nothing Then
        MsgBox "源工作簿中未找到Transaction Details工作表，程序退出"
        wbSource.Close SaveChanges:=False
        GoTo ResetSetting
    End If
    
    ' 绑定当前活动工作表为目标表
    Set wsTarget = ActiveSheet
    
    ' 弹窗选择筛选账号，默认取当前表B3
    On Error Resume Next
    Set accCell = Application.InputBox( _
        Prompt:="选择账号所在单元格，默认取当前表B3", _
        Title:="选择筛选账号", _
        Default:=wsTarget.Range("B3").Address, _
        Type:=8)
    If accCell Is Nothing Then
        wbSource.Close SaveChanges:=False
        GoTo ResetSetting
    End If
    accNum = Trim(accCell.Value)
    On Error GoTo 0
    If accNum = "" Then
        MsgBox "选中的账号为空，程序退出"
        wbSource.Close SaveChanges:=False
        GoTo ResetSetting
    End If
    
    ' 清空目标表A7以下的历史数据
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    If lastRowTarget >= 7 Then
        wsTarget.Range("A7:C" & lastRowTarget).ClearContents
    End If
    
    ' 源表执行筛选，自动补全前导负号匹配源格式
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "E").End(xlUp).Row
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
    wsSource.Range("A1:F" & lastRowSource).AutoFilter Field:=5, Criteria1:="-" & accNum
    
    ' 定位筛选后需要复制的A、C、F列可见数据（跳过表头行）
    On Error Resume Next
    Set copyRng = Intersect( _
        wsSource.Range("A2:A" & lastRowSource & ",C2:C" & lastRowSource & ",F2:F" & lastRowSource), _
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible))
    On Error GoTo 0
    
    If copyRng Is Nothing Then
        MsgBox "未找到账号【" & accNum & "】对应的交易记录"
        wbSource.Close SaveChanges:=False
        GoTo ResetSetting
    End If
    
    ' 粘贴值到目标表A7位置
    copyRng.Copy
    wsTarget.Range("A7").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
    ' 清理源表状态，关闭源文件
    wsSource.AutoFilterMode = False
    wbSource.Close SaveChanges:=False
    
    ' 自动删除C列金额为负数的整行
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "C").End(xlUp).Row
    If lastRowTarget >= 7 Then
        For i = lastRowTarget To 7 Step -1
            If IsNumeric(wsTarget.Cells(i, "C").Value) And wsTarget.Cells(i, "C").Value < 0 Then
                wsTarget.Rows(i).Delete
            End If
        Next i
    End If
    
    MsgBox "账号【" & accNum & "】数据提取完成"

ResetSetting:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.CutCopyMode = False
End Sub

注意：如果源工作簿中交易明细的工作表名不是Transaction Details，可修改代码中对应工作表名参数适配实际场景。

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