vba excel 宏 - 错误 5 需要帮助查看问题，在循环之前失败

Question

全部-我在使用这段代码时遇到了问题。我确信这是一个简单的修复或语法，但我没有看到它。代码循环遍历分水岭数据目录。在单费率区域分水岭上，后缀为 _0，在多费率分水岭上，文件分为子流域 _1、_2、_3 等，以设置不同的费率代码。多个棚屋需要合并回单个 _0 文件，然后导入税务软件。所有数据均位于每个工作簿的第 1 页上。这是代码。它挂在循环之前的 filename = Dir 上。如果您对如何做得更好有任何建议 - 请提出建议。我不明白为什么它在循环之前挂在文件名上 - 因为我有其他宏进行速率代码更改等，所有这些都使用相同的格式 - 并且它们有效。

Sub Merge()

Dim folder As String 'used
Dim path As String 'used

Dim fileName As String

Dim file() As String
Dim Watershed As String
Dim Subshed As Integer
Dim previous As Integer

Dim outputFileName As String
Dim wbOutput As Workbook
Dim wsOutput As Worksheet
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
Dim fileCount As Integer

folder = Year(Now()) & "_Excel\"
'path = "J:\Projects\DekalbCo\Surveyor\Surveyor GIS Data\" & folder
path = "J:\Projects\DekalbCo\Surveyor\Surveyor GIS Data\2024_excel\test\"

' Loop through each file in the folder
fileName = Dir(path & "*.xls")
Debug.Print fileName

'initialize subshed to 0
previous = 0

Do While fileName <> ""

 ' Extract Watershed and Subshed from the filename
    file = Split(fileName, "_")
    Watershed = file(0) & "_" & file(1)
    Debug.Print Watershed
    Subshed = Left(file(2), 1)
    Debug.Print Subshed

    ' Check if Subshed is greater than 0
    If Subshed > previous Then
        previous = Subshed
        
        ' Check if output workbook exists for this prefix, create if not
        outputFileName = path & Watershed & "_0.xls"
        If Dir(outputFileName) = "" Then
           Set wbOutput = Workbooks.Add
           wbOutput.SaveAs outputFileName
           Set wsOutput = wbOutput.Sheets(1)
           isFirstFile = True
        Else
           Set wbOutput = Workbooks.Open(outputFileName)
           Set wsOutput = wbOutput.Sheets(1)
           isFirstFile = False
        End If
        
        ' Open the current file
        Set wbTemp = Workbooks.Open(path & fileName)
        Set wsTemp = wbTemp.Sheets(1)
            
        ' Copy data to the output workbook
        If Not isFirstFile Then
        ' Remove header from the second and subsequent sheets
            If wsTemp.UsedRange.Rows.Count > 1 Then
            wsTemp.Rows(1).Delete
            End If
        End If
        wsTemp.UsedRange.Copy wsOutput.Cells(wsOutput.Cells(Rows.Count, 1).End(xlUp).Row, 1)
            
        ' Close the temporary workbook without saving
        wbTemp.Close False
            
        ' Close and save the output workbook
        wbOutput.Close True
            
        ' Increment file count
        'fileCount = fileCount + 1
        
    End If
    
    ' Get the next file
    fileName = Dir
Loop
End Sub

Answer 1

这里有一个关于如何管理此问题的建议（未经测试）：

Option Explicit

Const PATH_ROOT As String = "J:\Projects\DekalbCo\Surveyor\Surveyor GIS Data\2024_excel\test\"

Sub Merge()
    Dim dict As Object, f As String, lr As Long, rngCopy As Range, k
    Dim Watershed As String, Subshed As Long, wbZero As Workbook, wsZero As Worksheet, wb As Workbook
    
    Set dict = CreateObject("scripting.dictionary")
    dict.CompareMode = 1 'case-insensitive
    
    'start by collecting all source files with specific pattern
    f = Dir(PATH_ROOT & "*_*_*.xls")
    Do While Len(f) > 0
        If InStr(f, "_0.xls") = 0 Then 'not collecting "zero" files
            dict.Add f, True 'a file we need to process?
        End If
        f = Dir()
    Loop
    
    'loop over files
    For Each k In dict
        Watershed = GetWatershed(k)
        Subshed = GetSubshed(k)
        'open source
        Set wb = Workbooks.Open(PATH_ROOT & k)
        Set rngCopy = wb.Worksheets(1).UsedRange
        'open destination and copy content
        Set wbZero = ZeroFile(Watershed)
        With wbZero.Worksheets(1)
            lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            If lr = 1 Then
                rngCopy.Copy .Cells(lr, 1)  'first data: include headers
            Else
                rngCopy.Offset(1).Copy .Cells(lr + 1, 1) 'skip headers
            End If
        End With
        wb.Close savechanges:=False
        wbZero.Close savechanges:=True
    Next k
    
End Sub

'handle parameter extraction
Function GetWatershed(fName) As String
    Dim arr
    arr = Split(fName, "_")
    GetWatershed = arr(0) & "_" & arr(1)
End Function
Function GetSubshed(fName) As Long
    Dim arr
    arr = Split(fName, "_")
    GetSubshed = CLng(Replace(arr(2), ".xls", ""))
End Function
'construct file name
Function FileName(Watershed As String, Subshed As Long) As String
    FileName = Watershed & "_" & Subshed & ".xls"
End Function

'return a reference to the (opened) "zero" file for a given watershed
Function ZeroFile(Watershed As String) As Workbook
    Dim fName As String
    fName = FileName(Watershed, 0)
    If Len(Dir(PATH_ROOT & fName, vbNormal)) = 0 Then
        Set ZeroFile = Workbooks.Add(xlWBATWorksheet) 'has one worksheet
        ZeroFile.SaveAs PATH_ROOT & fName
    Else
        Set ZeroFile = Workbooks.Open(PATH_ROOT & fName)
    End If
End Function

关于每个摘要文件中的复制/粘贴顺序是否重要的开放问题。