VBA数组赋值单元格区域时触发Error 1004问题求助

错误原因分析 #

Error 1004 触发于wsDest.Cells(DestRow, "H").Offset(0, PasteColumn - 1).Value = CopyValues(1, PasteColumn)，核心问题有3个：

1. DestRow 并非有效行号：原代码中XLookup返回的是目标工作表A列的单元格内容（如3_IAM to Alpha Bank Cyprus），而非行号，用文本字符串作为行号调用Cells方法会触发引用无效错误。
2. 粘贴起始列不符合需求：原代码从H列开始粘贴，但需求要求从G列开始。
3. 文件名数字提取逻辑有漏洞：若文件名包含非数字前缀（如Asset_3.xlsx），原提取逻辑会错误获取整个前缀，导致匹配失败。

修正后的完整代码 #

Sub CopyDataFromFiles()
    Dim SourceFolder As String
    Dim FileName As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim FoundRow As Range
    Dim CopyRange As Range
    Dim DestRow As Long ' 改为Long类型存储行号
    Dim EconomicValue As String
    Dim NumberInFileName As String
    Dim CopyValues As Variant
    Dim PasteColumn As Long
    Dim i As Integer
    
    ' 关闭屏幕更新与提示
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 设置共享文件夹路径（HTTP路径需转为UNC格式或映射为网络驱动器）
    SourceFolder = "\\dms\divs\riskoper\Shared Documents\MORisk\Shared_Folder\IRRBB\DV01\2024-03-31\Flat without EV Spread\Assets\"
    
    ' 设置目标工作表
    Set wsDest = ThisWorkbook.Sheets(1) ' 可根据实际修改表名或索引
    
    ' 遍历文件夹内所有xlsx文件
    FileName = Dir(SourceFolder & "*.xlsx")
    Do While FileName <> ""
        ' 提取文件名开头的连续数字（兼容"3.xlsx"或"Asset_3.xlsx"等格式）
        NumberInFileName = ""
        For i = 1 To Len(FileName)
            If IsNumeric(Mid(FileName, i, 1)) Then
                NumberInFileName = NumberInFileName & Mid(FileName, i, 1)
            Else
                Exit For ' 遇到非数字字符停止提取
            End If
        Next i
        
        ' 打开源工作簿
        Set wbSource = Workbooks.Open(SourceFolder & FileName)
        If Not wbSource Is Nothing Then
            Set wsSource = wbSource.Sheets(1) ' 假设数据在第一个工作表
            
            ' 查找A列中"Economic Value"所在行
            EconomicValue = "Economic Value"
            Set FoundRow = wsSource.Columns("A:A").Find(What:=EconomicValue, LookIn:=xlValues, LookAt:=xlWhole)
            
            If Not FoundRow Is Nothing Then
                ' 复制"Economic Value"行中从B列到最后有数据的列
                Dim LastCol As Long
                LastCol = wsSource.Cells(FoundRow.Row, wsSource.Columns.Count).End(xlToLeft).Column
                Set CopyRange = wsSource.Range(wsSource.Cells(FoundRow.Row, "B"), wsSource.Cells(FoundRow.Row, LastCol))
                CopyValues = CopyRange.Value
                
                ' 查找目标表A列中以[数字]_开头的行，返回行号
                Dim LookupValue As String
                LookupValue = NumberInFileName & "_*" ' 匹配开头为数字+下划线的内容
                On Error Resume Next
                DestRow = Application.WorksheetFunction.XLookup(LookupValue, wsDest.Columns("A:A"), wsDest.Columns("A:A").Row, , 2)
                On Error GoTo 0
                
                If DestRow > 0 Then
                    ' 从G列（第7列）开始粘贴数据
                    For PasteColumn = LBound(CopyValues, 2) To UBound(CopyValues, 2)
                        wsDest.Cells(DestRow, "G").Offset(0, PasteColumn - 1).Value = CopyValues(1, PasteColumn)
                    Next PasteColumn
                Else
                    MsgBox "未找到匹配项：" & NumberInFileName & "（文件名：" & FileName & "）"
                End If
            Else
                MsgBox "文件" & FileName & "中未找到'Economic Value'"
            End If
            
            ' 关闭源工作簿不保存
            wbSource.Close SaveChanges:=False
        Else
            MsgBox "无法打开文件：" & FileName
        End If
        
        ' 获取下一个文件
        FileName = Dir
    Loop
    
    ' 恢复屏幕更新与提示
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "数据复制完成。"
End Sub

关键修改点说明 #

1. 修正DestRow获取逻辑：将XLookup的返回值改为行号，查找值改为NumberInFileName & "_*"，确保精准匹配目标表A列中以数字+下划线开头的行。
2. 调整粘贴起始列：将Cells(DestRow, "H")改为Cells(DestRow, "G")，符合需求中从G列开始粘贴的要求。
3. 优化文件名数字提取：通过循环提取文件名开头的连续数字，兼容多种文件名格式。
4. 缩小复制范围：仅复制"Economic Value"行中从B列到最后有数据的列，避免无效空列的冗余处理。

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