如何修复VBA代码中的‘Input past end of file’错误？

错误本质 #

这个错误是因为你尝试读取空文件，或者文件还没完成写入就被读取，常见触发场景：

• 发布HTML文件后，系统还没写完文件/释放锁，就立刻执行ReadAll
• 透视表复制的内容为空，导致生成的HTML文件没有有效数据
• 文件路径错误，实际生成的文件不在指定位置，读取了一个不存在的空文件

具体修复步骤 #

1. 给文件写入留缓冲时间 #

在Publish操作后加一段延时，让系统完成文件写入：

With ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
    fileName:=fileName, Sheet:=newwb.Sheets(1).Name, Source:=newwb.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
        .Publish (True)
        .AutoRepublish = False
End With
' 等待2秒，确保文件写入完成
Application.Wait Now + TimeValue("00:00:02")

2. 先检查文件有效性再读取 #

读取前判断文件是否存在且非空，避免读取无效文件：

' 验证文件状态
If fso.FileExists(fileName) And fso.GetFile(fileName).Size > 0 Then
    readall = fso.OpenTextFile(fileName, 1).ReadAll
Else
    MsgBox "生成的HTML文件为空或不存在，请检查透视表内容", vbExclamation
    Exit Sub
End If

3. 修正文件路径问题 #

如果原文件未保存，ThisWorkbook.Path会是空值，导致文件生成在Excel默认路径。改用明确的桌面路径更可靠：

' 直接指定桌面路径，避免路径为空的问题
fileName = Environ("USERPROFILE") & "\Desktop\PivotTable.htm"

4. 确保透视表有可复制的内容 #

复制前检查透视表是否有数据，避免生成空HTML：

Sheets("Missing").Select
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables("PivotTable1")
' 检查透视表是否存在数据行
If pt.DataBodyRange Is Nothing Then
    MsgBox "透视表没有数据，无法生成内容", vbExclamation
    Exit Sub
End If
pt.PivotSelect "", xlDataAndLabel, True
Selection.Copy

完整修复后的代码 #

Sub Paste_Pivot()
    Dim pt As PivotTable
    Set pt = Sheets("Missing").PivotTables("PivotTable1")
    
    ' 检查透视表是否有数据
    If pt.DataBodyRange Is Nothing Then
        MsgBox "透视表没有数据，无法生成内容", vbExclamation
        Exit Sub
    End If
    
    pt.PivotSelect "", xlDataAndLabel, True
    Selection.Copy

    Workbooks.Add
    ActiveSheet.Paste
    Dim newwb As Workbook
    Set newwb = ActiveWorkbook

    Dim fso As Scripting.FileSystemObject, readall As Variant
    Set fso = New FileSystemObject
    Dim fileName As String
    ' 使用桌面路径，避免路径为空问题
    fileName = Environ("USERPROFILE") & "\Desktop\PivotTable.htm"
    
    With newwb.PublishObjects.Add(SourceType:=xlSourceRange, _
        fileName:=fileName, Sheet:=newwb.Sheets(1).Name, Source:=newwb.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
            .Publish (True)
            .AutoRepublish = False
    End With
    
    ' 等待文件写入完成
    Application.Wait Now + TimeValue("00:00:02")
    
    ' 检查文件是否有效
    If fso.FileExists(fileName) And fso.GetFile(fileName).Size > 0 Then
        readall = fso.OpenTextFile(fileName, 1).ReadAll
    Else
        MsgBox "生成的HTML文件为空或不存在", vbExclamation
        newwb.Close SaveChanges:=False
        Exit Sub
    End If

    Dim o As Outlook.Application
    Set o = New Outlook.Application
    Dim omail As Outlook.MailItem
    Set omail = o.CreateItem(olMailItem)

    omail.HTMLBody = "Hello" & "<Br>" & "<table align=left>" & readall & "</table>"
    omail.Display
    
    ' 清理临时文件和工作簿
    newwb.Close SaveChanges:=False
    Kill fileName
End Sub

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