我想将选择保存为新工作簿，但如果工作簿已经存在，我想在现有工作簿中保存为新工作表

Question

我对此还是很陌生。我希望能够执行以下操作：

select复制范围
在新工作簿中粘贴 selection
将工作簿保存在年份值在 H5 范围内的文件夹中（如果文件夹不存在，则创建一个）
将文件另存为 "title_month_year" 在 A5、F5、H5 范围内找到的值（但如果文件已存在，则另存为新 worksheet/tab）

到目前为止，我相信我已经涵盖了 1-3 个和 4 个的一部分。

Option Explicit
Const MYPATH As String = "C:\USERS58\Desktop\"

Sub IfNewFolder()
Dim AuditYear As String
    AuditYear = Range("H5").Value

'if a particular directory doesnt exists already then create folder.
If Len(Dir(MYPATH & AuditYear, vbDirectory)) = 0 Then
   MkDir MYPATH & AuditYear
End If

End Sub



Sub SaveCustomizedCourse()
'copy and past selected data in a new workbook

Range("B8").End(xlDown).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.Copy

    Workbooks.Add
    ActiveSheet.Paste

    Range("A1").Select
    Selection.PasteSpecial xlPasteColumnWidths
    Selection.PasteSpecial xlPasteFormats


'save selected data in a new workbook
Dim AuditMonth As String
Dim AuditYear As String
Dim AuditTitle As String

    AuditMonth = Range("F5").Value 'MONTH
    AuditYear = Range("H5").Value 'YEAR
    AuditTitle = Range("A5").Value 'TITLE

    IfNewFolder 'creates a yearly subfolder

    ActiveWorkbook.SaveAs Filename:= _
    MYPATH & AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

        MsgBox ("Audit Saved.")

        'ActiveWindow.Close

End Sub

Answer 1

您可以添加下面的子程序并在 IfNewFolder 之后调用它，并删除它之后的所有代码。

Private Sub Carla(AuditMonth, AuditYear, AuditTitle)

Dim CurWb           As Workbook 'This is whatever workbook you are working with
Dim SaveAsWb        As Workbook 'This is spare for the workbook in case that has the same name
Dim SaveFileName    As String

Set CurWb = ActiveWorkbook
SaveFileName = AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm"

If Len(Dir(MYPATH & SaveFileName)) = 0 Then
    CurWb.SaveAs FileName:=MYPATH & SaveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else
    Set SaveAsWb = Workbooks.Open(MYPATH & SaveFileName)
    CurWb.Worksheets("Sheet1").Copy After:=SaveAsWb.Worksheets(Sheets.Count)
    SaveAsWb.Save
    SaveAsWb.Close
End If

MsgBox ("Audit Saved.")

End Sub

Answer 2

我稍微清除了你的代码 - 见下文。我假定 AuditMonth、AuditYear 和 AuditTitle 的值放在 "current" 工作簿中。

Sub SaveCustomizedCourse()
'copy and paste selected data in a new workbook
    Dim lngLastRow As Long
    Dim wksThis As Excel.Worksheet
    Dim wkbNew As Excel.Workbook
    'save selected data in a new workbook
    Dim AuditMonth As String
    Dim AuditYear As String
    Dim AuditTitle As String

    Set wksThis = ActiveSheet
    Set wkbNew = Workbooks.Add

    With wksThis
        lngLastRow = .Range("B8").End(xlDown).Row
        AuditMonth = .Range("F5").Value 'MONTH
        AuditYear = .Range("H5").Value 'YEAR
        AuditTitle = .Range("A5").Value 'TITLE
        .Range("B8:B" & lngLastRow).Copy
    End With

    With wkbNew.Sheets(1).Range("A1")
        .PasteSpecial xlPasteValuesAndNumberFormats
        .PasteSpecial xlPasteColumnWidths
    End With

    IfNewFolder 'creates a yearly subfolder

    With wkbNew
        .SaveAs Filename:= _
            MYPATH & AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        .Close
    End With

    MsgBox ("Audit Saved.")
End Sub

Answer 3

我发现 Peicong Chen post 的这种变体很有帮助。
它的工作原理和我想要的完全一样，谢谢。

Public Sub IfSheetExists(AuditMonth, AuditYear, AuditTitle)

    AuditMonth = Range("F5").Value 'MONTH
    AuditYear = Range("H5").Value 'YEAR
    AuditTitle = Range("A5").Value 'TITLE

    Dim CurWb           As Workbook 'This is whatever workbook you are working with
    Dim SaveAsWb        As Workbook 'This is spare for the workbook in case that has the same name
    Dim SaveFileName    As String

Set CurWb = ActiveWorkbook
SaveFileName = AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm"

Application.DisplayAlerts = False

If Len(Dir(MYPATH & SaveFileName)) = 0 Then
    Sheets("Sheet2").Delete
    Sheets("Sheet3").Delete
CurWb.SaveAs Filename:=MYPATH & SaveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
CurWb.Close

Else
    Set SaveAsWb = Workbooks.Open(MYPATH & SaveFileName)
    CurWb.Worksheets("Sheet1").Copy After:=SaveAsWb.Worksheets(Sheets.Count)
    SaveAsWb.save
    SaveAsWb.Close
    CurWb.Close
End If

Application.DisplayAlerts = True

MsgBox ("Audit Saved.")
Range("A1").Select

End Sub

我想将选择保存为新工作簿，但如果工作簿已经存在，我想在现有工作簿中保存为新工作表

I want to save a selection as a new workbook but if the workbook already exists i want to save as a new worksheet within the existing workbook instead

excel

vba

worksheet

save-as