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

VBA - Saving all worksheets as separate files with a file name based on a cell

提问by hispeedzintarwebz

I've found code to save all the worksheets, and I've found code to save the file with a filename based on a cell, but I can't seem to get both to work at the same time. Below is my entire macro - but the problem seems to stem from the last section: Sub(SheetSplit). I've tried all sorts of methods I've found online, but I need this to happen with a relative path - as in the same folder in which the workbooks are. The code is in a workbook called "Remit Macros.xls" and the multi-tabbed workbook I'm messing with is "RemitReport.xls" - what am I missing here? I always get an error of "Method 'SaveAs' of object '_Workbook' failed. What gives? I included the rest of the code in case it helps.

我找到了保存所有工作表的代码，我找到了使用基于单元格的文件名保存文件的代码，但我似乎无法让两者同时工作。下面是我的整个宏 - 但问题似乎源于最后一部分：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

Edit: After several of the suggestions I've been given, here is the last section of the code. It still doesn't work, but I think it's getting closer. I've also cleaned it up a little bit.

编辑：在我得到了几条建议之后，这里是代码的最后一部分。它仍然不起作用，但我认为它越来越近了。我也清理了一点。

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

采纳答案by Ross McConeghy

Try this, see comments in the code.

试试这个，查看代码中的注释。

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

回答by Alistair Weir

When the new workbook is created it has not yet been saved so relative path is just \sname so it can't save.

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

Move the relative pathline above the creation of the new book so:

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

Dim origpath as string, relativePath As String

Set wbSource = ActiveWorkbook
origpath = wbSource.path

Then

然后

relativePath = origpath & "\" & sname

You also need to change the sheetname line to:

您还需要将 sheetname 行更改为：

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

And you probably want to close each new book after it has been created or depending on the number of sheets in your original workbook you will have a lot of workbooks open:

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

wbDest.close

One final thing is you should be explicit about which Range("A1")you are clearing or it could also cause an error if removed from source wb as the next sheetname would be blank

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