每日首次运行VBA宏添加工作表触发Run-time error 1004问题

问题根源 #

你碰到的这个Run-time error 1004，说白了就是第一次跑宏的时候，你生成的dockactivity.xlsx里已经存在名为"Cases"的工作表。要么是前一天宏运行后没删干净旧文件，要么是你下载的原始Dock_Activity_*.xls本身就带这个工作表。你手动处理后等于重置了文件状态，所以后续运行就没问题了。

直接有效的解决方案 #

我们只需要在代码里加一段「检查并清理同名工作表」的逻辑，再优化下文件处理流程，就能彻底解决这个问题：

修改后的完整代码

Sub Schedule_macro()
 Dim Filename, Pathname, SaveFileName As String
 Dim wb As Workbook
 Dim UserName As String
 Dim ws As Worksheet
 Dim sheetExists As Boolean
 
 UserName = Environ("username")
 Pathname = "C:\Users\" & Environ$("username") & "\Downloads\"
 Filename = Dir(Pathname & "Dock_Activity_*.xls")
 SaveFileName = Pathname & "dockactivity.xlsx" ' 修正为完整路径，避免保存位置混乱
 Application.DisplayAlerts = False
 
 ' 检查是否找到目标下载文件
 If Len(Filename) = 0 Then
 MsgBox "You need to download the" & vbNewLine & "Dock Activity Report from the" & vbNewLine & "'Report Run Log' in Lean." & vbNewLine & vbNewLine & "Once downloaded, please rerun the macro", vbCritical, "HiRise Schedule Macro"
 Debug.Print "could not find Filename within given Pathname"
 Debug.Print "exiting macro"
 Exit Sub
 End If
 
 ' 处理下载的xls文件，转换为xlsx
 Do While Filename <> ""
 Set wb = Workbooks.Open(Pathname & Filename)
 wb.CheckCompatibility = True
 Application.DisplayAlerts = False
 ' 直接保存到完整路径，强制覆盖已有文件
 wb.SaveAs Filename:=SaveFileName, FileFormat:=xlOpenXMLWorkbook
 wb.Close SaveChanges:=False
 Filename = Dir() ' 简化循环，避免重复调用Dir导致的问题
 Loop
 Application.DisplayAlerts = True
 
 ' 删除原始xls下载文件
 Kill Pathname & "Dock_Activity_*.xls"
 
 ' 打开转换后的xlsx文件
 Debug.Print "opening dockactivity.xlsx"
 Set wb = Workbooks.Open(SaveFileName)
 Windows("dockactivity.xlsx").Activate
 
 ' --- 以下是你原有的格式化代码，保持不变 ---
 Rows("1:21").Delete Shift:=xlUp
 Range("A:B,D:F,H:N,S:S,U:V,X:Y,AB:AK,AM:BA").Delete Shift:=xlToLeft
 Columns("H:H").Cut
 Columns("A:A").Insert Shift:=xlToRight
 Columns("K:K").Cut
 Columns("G:G").Insert Shift:=xlToRight
 Columns("J:K").Copy
 Range("L1").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 Columns("J:K").ClearContents
 Range("J1").FormulaR1C1 = "Trailer Number"
 Range("K1").FormulaR1C1 = "Arrival Time"
 Columns("G:M").Copy
 Range("N1").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 Selection.ClearContents
 Range("N1").FormulaR1C1 = "Door"
 Range("O1").FormulaR1C1 = "Ship Rail"
 Range("P1").FormulaR1C1 = "Staged"
 Range("Q1").FormulaR1C1 = "Check If Loaded"
 Range("R1").FormulaR1C1 = "Case Picks"
 Range("S1").FormulaR1C1 = "Layer Picks"
 Range("T1").FormulaR1C1 = "Check if Released by Pool"
 Debug.Print "1:1 table headers complete"
 
 Columns("A:B").ColumnWidth = 17.71
 Columns("C:C").ColumnWidth = 19.14
 Columns("D:D").ColumnWidth = 25.71
 Columns("E:E").ColumnWidth = 14.41
 Columns("F:F").ColumnWidth = 10.71
 Columns("G:G").ColumnWidth = 30.29
 Columns("H:H").ColumnWidth = 9.43
 Columns("I:I").ColumnWidth = 13.71
 Columns("J:J").ColumnWidth = 26.14
 Columns("K:L").ColumnWidth = 23.57
 Columns("M:M").ColumnWidth = 46
 Columns("N:S").ColumnWidth = 15
 Columns("T:T").ColumnWidth = 12.86
 Debug.Print "column resizing complete"
 
 Cells.Select
 With Selection.Font
 .Name = "Arial"
 .Size = 14
 .Strikethrough = False
 .Superscript = False
 .Subscript = False
 .OutlineFont = False
 .Shadow = False
 .Underline = xlUnderlineStyleNone
 .TintAndShade = 0
 .ThemeFont = xlThemeFontNone
 End With
 Rows("1:1").RowHeight = 75
 Rows("2:150").RowHeight = 55
 ' --- 原格式化代码结束 ---
 
 ' 新增核心逻辑：检查并清理同名工作表
 ' 先检查"Cases"表是否存在，存在则删除（也可以改成重命名，按需调整）
 sheetExists = False
 For Each ws In wb.Sheets
 If ws.Name = "Cases" Then
 sheetExists = True
 Exit For
 End If
 Next ws
 If sheetExists Then
 Application.DisplayAlerts = False
 wb.Sheets("Cases").Delete
 Application.DisplayAlerts = True
 End If
 
 ' 再检查"Layers"表是否存在
 sheetExists = False
 For Each ws In wb.Sheets
 If ws.Name = "Layers" Then
 sheetExists = True
 Exit For
 End If
 Next ws
 If sheetExists Then
 Application.DisplayAlerts = False
 wb.Sheets("Layers").Delete
 Application.DisplayAlerts = True
 End If
 
 ' 现在可以安全添加新工作表了
 Sheets.Add(After:=Sheets("Dock Activity Report")).Name = "Cases"
 Sheets.Add(After:=Sheets("Cases")).Name = "Layers"
 
 ' --- 以下是你原有的后续代码，保持不变 ---
 Sheets("Dock Activity Report").Range("R2:R150").FormulaR1C1 = "=VLOOKUP(RC[-17],Cases!C[-13]:C[-12],2,FALSE)"
 Sheets("Dock Activity Report").Range("S2:S150").FormulaR1C1 = "=VLOOKUP(RC[-18],Layers!C[-15]:C[-14],2,FALSE)"
 Worksheets("Dock Activity Report").Select
 Range("A2:T150").Select
 Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
 "=$C2=""Live Trailer"""
 Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
 With Selection.FormatConditions(1).Interior
 .PatternColorIndex = xlAutomatic
 .Color = 65535
 .TintAndShade = 0
 End With
 Range("B2:B150").Select
 ActiveWorkbook.Worksheets("Dock Activity Report").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("Dock Activity Report").Sort.SortFields.Add Key:= _
 Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ActiveWorkbook.Worksheets("Dock Activity Report").Sort
 .SetRange Range("A1:T150")
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
 ActiveWorkbook.Worksheets("Dock Activity Report").Select
 Columns("A:A").Copy
 Columns("B:B").Insert Shift:=xlToRight
 Range("B2").Select
 Application.CutCopyMode = False
 ActiveCell.FormulaR1C1 = "=IFERROR(RC[-1]*1,TRIM(RC[-1]))"
 Range("B3").Select
 Range("B2").Select
 Selection.AutoFill Destination:=Range("B2:B150"), Type:=xlFillDefault
 Range("B2:B150").Select
 Columns("B:B").Copy
 Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 Columns("B:B").Select
 Application.CutCopyMode = False
 Selection.Delete Shift:=xlToLeft
 Debug.Print "A:A value reformat complete"
 Sheets("Dock Activity Report").Select
 Columns("A:T").Select
 Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
 "=COUNTA($A1:$F1)>0"
 Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
 With Selection.FormatConditions(1).Borders
 .LineStyle = xlContinuous
 .TintAndShade = 0
 .Weight = xlThin
 End With
 Selection.FormatConditions(1).StopIfTrue = False
 Debug.Print "cell borders added"
 Dim r As Long
 Dim LastRow As Long
 LastRow = Cells(Rows.Count, "A").End(xlUp).Row
 For r = LastRow To 1 Step -1
 If Cells(r, 1) = 0 Then
 Rows(r).Delete
 End If
 Next r
 Range("A1").Select
 Sheets("Cases").Range("E2:E300").FormulaR1C1 = "=VALUE(TRIM(CLEAN(RC[-4])))"
 Sheets("Cases").Range("F2:F300").FormulaR1C1 = "=RC[-2]"
 Sheets("Cases").Columns("E:F").EntireColumn.Hidden = True
 Sheets("Layers").Range("D2:D300").FormulaR1C1 = "=VALUE(TRIM(CLEAN(RC[-3])))"
 Sheets("Layers").Range("E2:E300").FormulaR1C1 = "=RC[-2]"
 Sheets("Layers").Columns("D:E").EntireColumn.Hidden = True
 Sheets("Dock Activity Report").Range("A1").Select
 Application.DisplayAlerts = False
 ActiveWorkbook.Save
 Application.DisplayAlerts = True
 MsgBox "All Finished!", vbInformation, "HiRise Schedule"
 ActiveWorkbook.Save
End Sub

几个关键修改的作用 #

1. 工作表冲突预处理：在添加新的"Cases"和"Layers"表之前，先遍历检查是否已有同名表，有的话直接删除（你也可以改成重命名，比如把旧表改成Cases_Old，方便排查问题），从根源避免重名错误。
2. 优化文件保存逻辑：把SaveFileName改成完整路径，确保每次转换的xlsx文件都保存在Downloads目录，而且强制覆盖旧文件，避免残留旧表。
3. 简化循环逻辑：修正了原代码中Dir调用的重复问题，避免一次处理多个文件时出现异常。

这样改完之后，不管是首次运行还是后续运行，宏都会自动处理同名工作表的问题，再也不用手动折腾文件啦。

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