Question

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

Answer 1

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

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

Dim origpath as string, relativePath As String

Set wbSource = ActiveWorkbook
origpath = wbSource.path

然后

relativePath = origpath & "\" & sname

您还需要将工作表名称行更改为：

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

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

wbDest.close

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

Answer 2

试试这个，请参阅代码中的注释。

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 - 将所有工作表保存为具有基于单元格的文件名的单独文件

2 个答案: