如何使用VBA打开多个加密Excel文件并批量复制数据到指定工作表

报错直接原因 #

你没有提前声明并给OutputSheet对象赋值，VBA无法识别这个变量指向的工作表实例，因此抛出「需要对象」错误。

除此之外你的代码还存在多处逻辑缺失/错误：

• 缺少打开加密Excel文件的核心逻辑
• 当前复制操作仅复制了存储文件名的单元格，而非目标加密文件内的数据
• 粘贴位置定位逻辑写法错误
• 缺少操作完成后关闭已打开加密文件的逻辑

修复后完整可运行代码 #

Option Explicit
Public Sub OpenPwdProtFiles()
    Dim ict As Long
    Dim FileNames As Range, paths As Range, passwords As Range, CornerCell As Range
    Dim Filename As Range
    Dim mypath As String, mypwd As String, fullPath As String
    Dim OutputSheet As Worksheet
    Dim wbSource As Workbook
    Dim sourceData As Range
    Dim cell2paste As Range
    
    ' 绑定当前工作簿的Output工作表，解决对象缺失报错
    Set OutputSheet = ThisWorkbook.Worksheets("Output")
    ' 初始化变量
    ict = 0
    Set FileNames = Range("Filenames")
    Set paths = Range("Paths")
    Set passwords = Range("Passwords")
    Set CornerCell = Range("CornerCell") ' 请确保你已经定义了这个命名范围指向Output表的起始粘贴单元格

    For Each Filename In FileNames
        ict = ict + 1
        If Filename.Text <> "" Then
            mypath = paths.Item(ict).Value
            mypwd = passwords.Item(ict).Value
            ' 拼接完整文件路径
            fullPath = mypath & IIf(Right(mypath, 1) = "\", "", "\") & Filename.Text
            ' 打开带密码的Excel文件
            Set wbSource = Workbooks.Open(Filename:=fullPath, Password:=mypwd, ReadOnly:=True)
            ' 复制第一个工作表的全部有效数据（如果需要复制所有工作表可自行循环工作表集合）
            Set sourceData = wbSource.Worksheets(1).UsedRange
            sourceData.Copy
            ' 定位Output表的空行粘贴位置
            OutputSheet.Activate
            Set cell2paste = CornerCell.End(xlDown).Offset(1, 0)
            cell2paste.PasteSpecial xlPasteValues
            ' 关闭打开的加密文件，不保存
            wbSource.Close SaveChanges:=False
            ' 清空剪贴板
            Application.CutCopyMode = False
        End If
    Next
    MsgBox "全部数据合并完成！", vbInformation
End Sub

注意事项 #

• 代码默认仅提取加密文件的第一个工作表数据，如果你需要提取文件内所有工作表数据，可自行新增循环wbSource.Worksheets的逻辑
• 请确保你已经提前在当前工作簿定义了CornerCell命名范围，指向Output表中数据粘贴的起始单元格
• 运行前请确认存储的文件路径、文件名、密码没有录入错误，避免打开文件失败

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