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

【问题标题】：VBA - Saving all worksheets as separate files with a file name based on a cellVBA - 将所有工作表保存为单独的文件，文件名基于单元格
【发布时间】：2014-08-13 20:58:01
【问题描述】：

我找到了保存所有工作表的代码，并且我找到了使用基于单元格的文件名保存文件的代码，但我似乎无法让两者同时工作。下面是我的整个宏 - 但问题似乎源于最后一部分：Sub(SheetSplit)。我已经尝试了我在网上找到的各种方法，但我需要使用相对路径来实现 - 就像在工作簿所在的同一文件夹中一样。该代码位于名为“Remit Macros.xls”的工作簿中，而我正在处理的多选项卡式工作簿是“RemitReport.xls” - 我在这里缺少什么？我总是收到“对象'_Workbook'的方法'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

编辑：在给出了几个建议之后，这是代码的最后一部分。它仍然不起作用，但我认为它越来越接近了。我也稍微清理了一下。

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 origpath As String
Dim relativePath As String
Set wbSource = ActiveWorkbook
    origpath = wbSource.Path
    'relativePath = origpath & "\" & sname
    'sname = sht.Range("A1") & ".xls"
        For Each sht In wbSource.Sheets
            sht.Copy
            Set wbDest = ActiveWorkbook
            sname = sht.Range("A1") & ".xls"
            relativePath = origpath & "\" & sname
            'relativePath = Application.ActiveWorkbook.Path & "\" & sname
            Application.DisplayAlerts = False
            ActiveWorkbook.CheckCompatibility = False
            ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=56
            Application.DisplayAlerts = True
'Range("A1").Clear
Next
MsgBox "Done!"
End Sub

【问题讨论】：

如果您尝试保存只读文件，SaveAs 可能会失败。您是否检查过以确保您没有尝试保存现有文件？暂时注释掉Application.DisplayAlerts = False 行可能会有所帮助，这样您就可以看到任何与文件相关的错误提示，直到您修复错误为止。
我会尝试评论该行以获得更多详细信息 - 但我正在使用的目录中没有其他文件。
确定没有其他文件，也就是说，直到您开始通过宏将新文件保存在那里。我的猜测是工作表的单元格 A1 中的某些值是相同的，因此它试图保存宏刚刚保存并且仍然打开的文件，因为您在保存新工作簿后没有关闭它们。如果文件已经存在，您似乎需要弄清楚该怎么做，因为以前的工作表在单元格 A1 中具有相同的名称。
该宏的目的是每次都在一个干净的文件夹中使用，实际上它每天都会在不同的文件夹中，从没有文件开始，文件夹名称是当天的日期。宏还不够远（由于错误）来保存第一个文件，但是当我检查文件夹以防万一时，那里仍然没有其他文件 - 只有宏文件和正在使用的源文件生成要保存的不同报告。编辑澄清：即使在测试中，我每次都在一个干净的文件夹中运行它。
您是否检查过relativePath 是有效的文件路径和名称，没有无效字符？

标签： excel save filenames vba

【解决方案1】：

试试这个，看看代码中的cmets。

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

【讨论】：

天哪，它有效！非常感谢！我唯一改变的是我注释掉了关闭它们的行 - 然后必须在关闭之前单独查看它们，但这仍然是一个很大的帮助！
很高兴为您提供帮助。您可以在要检查中断时的值的变量上使用“监视”，这是 VBA IDE 的调试功能。 MSDN 文章在这里：msdn.microsoft.com/en-us/library/ee440547(v=office.12).aspx 如果您为 relativePath 变量设置了监视，您会看到该值类似于“\.xls”，这是一个无效的文件路径。

【解决方案2】：

新工作簿创建时尚未保存，因此相对路径只是 \sname，因此无法保存。

将相对路径移动到新书的创建上方，这样：

Dim origpath as string, relativePath As String

Set wbSource = ActiveWorkbook
origpath = wbSource.path

然后

relativePath = origpath & "\" & sname

您还需要将 sheetname 行更改为：

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

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

wbDest.close

最后一件事是您应该明确说明您正在清除哪个Range("A1")，否则如果从源 wb 中删除它也可能导致错误，因为下一个工作表名称将为空白

【讨论】：

删除了我以前的 cmets，其中包含很多难以阅读的代码......所以我在上面的 Set wbSourse 中输入了你的第一行，它有一个编译错误，因为在上一行我有 Dim relativePath作为字符串，所以我将前一行注释掉了。在“origpath = ...”之后添加了第二个块，然后在第三个块中更改了范围引用。注释掉了 A1 的行清理范围，我需要让它们保持打开状态，因为它们都必须快速审查。我仍然遇到同样的错误。
是的，这会产生编译错误，我的意思是调整原始声明，然后调整相对路径分配，这将与接受的答案完全一致。