如何用VBA调用IE实现多文件批量下载、自动重命名并存储到指定文件夹

原代码核心问题 #

• 未按数组下标循环拼接对应文件的URL，直接将数组整体拼接进URL导致路径无效
• 下载触发逻辑未等待IE页面加载完成，SendKeys触发时机不对容易失效
• 缺少下载完成判定、文件匹配重命名、移动到指定目录的逻辑
• 变量未声明，循环结构未闭合

修正后完整代码 #

Option Explicit
Sub FileFromURLDownloader()
    ' 声明变量
    Dim IE As Object
    Dim filecode As Variant, filenames As Variant
    Dim i As Long
    Dim baseURL As String, fullURL As String
    Dim defaultDownloadPath As String, targetSavePath As String
    Dim downloadFileName As String, newFileName As String
    Dim waitTime As Integer
    
    ' --------------- 配置项 请根据实际情况修改 ----------------
    baseURL = "https://website/api/v1/reportdata/" ' 基础接口地址
    filecode = Array("45551", "45552") ' 对应文件的编码数组，按顺序对应文件名前缀
    filenames = Array("ReportRU", "ReportUA") ' 文件名前缀，不需要带通配符和后缀
    defaultDownloadPath = "C:\Users\你的用户名\Downloads\" ' IE默认下载文件夹路径，末尾加\
    targetSavePath = "C:\Users\你的用户名\Desktop\目标存储文件夹\" ' 重命名后存储的路径，末尾加\
    waitTime = 10 ' 单文件最大等待下载时长（秒），网络慢可加大
    ' --------------------------------------------------------
    
    Application.ScreenUpdating = False
    ' 初始化IE对象
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False ' 后台运行
    
    ' 循环处理每个文件
    For i = LBound(filecode) To UBound(filecode)
        ' 拼接当前文件的完整URL
        fullURL = baseURL & filecode(i) & "/filename/" & filenames(i) & "*.xlsx"
        ' 导航到下载地址
        IE.navigate fullURL
        ' 等待页面加载完成
        Do While IE.Busy Or IE.readyState <> 4
            DoEvents
        Loop
        ' 等待下载提示框弹出，可根据实际情况调整等待时长
        Application.Wait Now + TimeValue("00:00:02")
        ' 触发保存（TAB次数根据实际下载提示框调整，默认是按TAB两次到保存按钮，回车确认）
        Application.SendKeys "{TAB}{TAB}{ENTER}", True
        ' 等待下载完成
        Dim spentTime As Integer
        spentTime = 0
        Do
            ' 匹配下载的文件
            downloadFileName = Dir(defaultDownloadPath & filenames(i) & "*.xlsx")
            If downloadFileName <> "" Then Exit Do
            Application.Wait Now + TimeValue("00:00:01")
            spentTime = spentTime + 1
            If spentTime > waitTime Then
                MsgBox filenames(i) & " 下载超时，跳过该文件", vbExclamation
                GoTo nextFile
            End If
        Loop
        
        ' 重命名并移动文件
        newFileName = filenames(i) & ".xlsx"
        ' 检查目标路径是否存在重名文件，存在则先删除（可根据需求修改为不覆盖加后缀）
        If Dir(targetSavePath & newFileName) <> "" Then Kill targetSavePath & newFileName
        ' 移动并重命名
        Name defaultDownloadPath & downloadFileName As targetSavePath & newFileName
        
nextFile:
    Next i
    
    ' 释放资源
    IE.Quit
    Set IE = Nothing
    Application.ScreenUpdating = True
    MsgBox "批量下载处理完成", vbInformation
End Sub

使用注意事项 #

• 运行前需要将目标站点添加到IE的可信站点，关闭IE的弹出窗口拦截，避免下载提示框无法正常弹出
• 代码中SendKeys的TAB次数需要根据你IE的下载提示框实际情况调整，部分IE版本下载提示框默认焦点在运行按钮，可能需要调整TAB次数到保存按钮
• 若不需要覆盖已存在的同名文件，可自行修改重命名逻辑，比如给重复文件加序号后缀
• 若追求更高稳定性，可改用XMLHTTP或ADODB.Stream直接下载文件，不需要依赖IE浏览器，也不需要处理SendKeys的适配问题

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