Excel VBA-将所有工作表保存为单独的文件，文件名基于单元格

我找到了保存所有工作表的代码，也找到了使用基于单元格的文件名保存文件的代码，但我似乎无法让这两个文件同时工作。下面是我的整个宏-但问题似乎源于最后一节：Sub（SheetSplit）。我已经尝试了我在网上找到的各种方法，但我需要一个相对路径来实现这一点——就像在工作簿所在的文件夹中一样。代码在一个名为“remote Macros.xls”的工作簿中，我正在处理的多选项卡工作簿是“remotereport.xls”-我在这里遗漏了什么？我总是收到一个错误，对象“\u工作簿”的“方法”SaveAs失败。给出了什么？我包括了代码的其余部分，以防它有帮助

Sub RemitTotal()
    '
    ' Highlights remit amounts great enough for additional approvals
    '
    Workbooks.Open (ThisWorkbook.Path & "\RemitReport.xls")
    Windows("RemitReport.xls").Activate

    Dim i As Long
    For i = 1 To Worksheets.Count
        Sheets(i).Select

        BeginRow = 6
        EndRow = Range("A1000").End(xlUp).Row
        ChkCol = 18

        For RowCnt = BeginRow To EndRow - 9
            If Cells(RowCnt, ChkCol).Value > 500000 Then
                Range("R6:R1000").Select
                With Selection.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
                End With
            End If
        Next RowCnt
    Next i

    Call DateMacro

End Sub

Sub DateMacro()
    '
    ' Highlights dates not in the current month, i.e. early or late payments
    '
    Windows("RemitReport.xls").Activate

    Dim i As Long
    For i = 1 To Worksheets.Count
        Sheets(i).Select

        BeginRow = 6
        EndRow = Range("A1000").End(xlUp).Row
        ChkCol = 6

        For RowCnt = BeginRow To EndRow - 9
            If IsDate(Cells(RowCnt, ChkCol)) And Month(Date) <> Month(Cells(RowCnt, ChkCol - 1).Value) Then
                'date values no longer need to be updated monthly
                Cells(RowCnt, ChkCol - 1).Select
                With Selection.Interior
                .ColorIndex = 10
                .Pattern = xlSolid
                End With
            End If
        Next RowCnt

        BeginRow = 6
        EndRow = Range("A1000").End(xlUp).Row
        ChkCol = 6

        For RowCnt = BeginRow To EndRow - 9
            If Cells(RowCnt, ChkCol).Value = Cells(RowCnt, ChkCol - 1) + 30 Then
                Cells(RowCnt, ChkCol).Select
                With Selection.Interior
                    .ColorIndex = 0
                    .Pattern = xlSolid
                End With
            End If
        Next RowCnt
    Next i

    Call RemitNames

End Sub

Sub RemitNames()
    '
    'Adds lender remit name in the active worksheets in order to facilitate
    'saving each sheet under a different filename indicative of lender
    '
    Dim i As Long
    For i = 1 To Worksheets.Count
        Sheets(i).Select

        Range("A65536").End(xlUp).Select
        Selection.Copy
        Application.CutCopyMode = False
        Selection.Copy
        Range("D1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("E1").Select

        ActiveCell.Formula = "=RIGHT(D1,LEN(D1)-FIND("": "",D1))"
        Range("F1").Formula = "=TRIM(E1)"
        Range("D3:S3").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        Range("J1").Formula = "=INDEX('[Remit Macros.xls]Remit Codes'!$B1:$B999,MATCH(F1,'[Remit Macros.xls]Remit Codes'!$A1:$A999,0))"
        Range("J1").Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("D1:F1").Select
        Selection.ClearContents
        Range("J1").Select

    Next i

    Call SheetSplit

End Sub

Sub SheetSplit()
    '
    'Creates an individual workbook for each worksheet in the active workbook.
    '
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Object
    Dim strSavePath As String
    Dim sname As String
    Dim relativePath As String

    Set wbSource = ActiveWorkbook

    For Each sht In wbSource.Sheets

        sht.Copy
        Set wbDest = ActiveWorkbook

        sname = ThisWorkbook.ActiveSheet.Range("A1") & ".xls"
        relativePath = Application.ActiveWorkbook.Path & "\" & sname
        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        ActiveWorkbook.SaveAs FileName:=relativePath, FileFormat:=xlExcel8
        Application.DisplayAlerts = True

        Range("A1").Clear

    Next

    MsgBox "Done!"

End Sub

---

创建新工作簿时，它尚未保存，因此相对路径只是\n名称，因此无法保存

将相对路径线移动到新书创建上方，以便：

Dim origpath as string, relativePath As String

Set wbSource = ActiveWorkbook
origpath = wbSource.path

然后

您还需要将sheetname行更改为：

sname = sht.Range("A1") & ".xls"

您可能希望在每本新书创建后关闭它，或者根据原始工作簿中的工作表数量，您将打开许多工作簿：

wbDest.close

---

最后一件事是，您应该明确您要清除的

范围（“A1”）

，或者如果从源wb中删除，它也可能会导致错误，因为下一个sheetname将为空

尝试此操作，请参阅代码中的注释

Sub SheetSplit()
    '
    'Creates an individual workbook for each worksheet in the active workbook.
    '
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Object
    Dim strSavePath As String
    Dim sname As String
    Dim relativePath As String

    Set wbSource = ActiveWorkbook

    For Each sht In wbSource.Sheets

        sht.Copy
        Set wbDest = ActiveWorkbook

        sname = sht.Range("A1") & ".xls"
        relativePath = wbSource.Path & "\" & sname 'use path of wbSource

        wbDest.Sheets(1).Range("A1").Clear 'clear filename from new workbook cell A1

        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        ActiveWorkbook.SaveAs FileName:=relativePath, FileFormat:=xlExcel8
        Application.DisplayAlerts = True


        wbDest.Close False 'close the newly saved workbook without saving (we already saved)

    Next

    MsgBox "Done!"

End Sub

---

SaveAs

如果您试图在只读文件上保存，则可能会失败。是否已检查以确保您没有试图在现有文件上保存？暂时注释掉

Application.DisplayAlerts=False

行可能会有帮助，以便您可以看到任何与文件相关的错误提示，直到修复错误。我将尝试注释这一行是为了获得更多的细节-但是我使用的目录中没有其他文件。确保没有其他文件，也就是说，直到你开始通过宏在那里保存新文件。我猜工作表单元格A1中的一些值是相同的，所以它试图保存在宏刚刚保存并且仍然保存的文件上打开，因为在保存新工作簿后不会关闭它们。如果文件已经存在，您似乎需要弄清楚该怎么办，因为以前的工作表在单元格A1中具有相同的名称。宏计划每次都在一个干净的文件夹中使用，实际上，从没有文件和文件夹开始，它每天都在不同的文件夹中e是当天的日期。宏还不够远（由于错误）保存第一个文件，但当我检查文件夹以防万一时，那里仍然没有其他文件-只有宏文件和用于生成要保存的不同报告的源文件。编辑以澄清：即使在测试中，我每次都在一个干净的文件夹中运行它。您是否检查以确保

relativePath

是有效的文件路径和名称，没有无效字符？删除了我以前的注释，其中包含大量难以读取的代码…因此我在上面的集合wbSourse中键入了您的第一行，它有一个编译错误，因为在前一行中，我将Dim relativePath作为字符串，所以我注释掉了前一行。在“origpath=”之后添加了第二个块。。。“然后更改了第三个块中的范围参考。注释掉了行清除范围A1，我需要让它们保持打开状态，因为它们必须被快速地检查。我仍然得到了相同的错误。是的，这会产生编译错误。我的意思是调整原始声明，然后调整相对路径分配，这将与接受的答案完全一样。哦，天哪，它工作了！非常感谢你！我唯一改变的是我注释掉了关闭它们的行-它们必须在关闭之前单独查看，但这仍然是一个很大的帮助！很乐意帮忙。当出现中断时，可以对要检查其值的变量使用“监视”，这是VBA IDE的调试功能。MSDN文章：如果您为relativePath变量设置了一个手表，您会看到该值类似于“\.xls”，这是一个无效的文件路径。

wbDest.close

Sub SheetSplit()
    '
    'Creates an individual workbook for each worksheet in the active workbook.
    '
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Object
    Dim strSavePath As String
    Dim sname As String
    Dim relativePath As String

    Set wbSource = ActiveWorkbook

    For Each sht In wbSource.Sheets

        sht.Copy
        Set wbDest = ActiveWorkbook

        sname = sht.Range("A1") & ".xls"
        relativePath = wbSource.Path & "\" & sname 'use path of wbSource

        wbDest.Sheets(1).Range("A1").Clear 'clear filename from new workbook cell A1

        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        ActiveWorkbook.SaveAs FileName:=relativePath, FileFormat:=xlExcel8
        Application.DisplayAlerts = True


        wbDest.Close False 'close the newly saved workbook without saving (we already saved)

    Next

    MsgBox "Done!"

End Sub