我想将选择另存为新工作簿，但是如果该工作簿已存在，我想另存为现有工作簿中的新工作表

Question

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

1. 选择复印范围
2. 在新工作簿中粘贴选择
3. 将工作簿保存在文件夹中，年份值在H5范围内（如果文件夹不存在，则创建一个）
4. 将文件另存为A5，F5，H5范围内的“ title_month_year”值（但如果文件已存在，另存为新的工作表/标签）

到目前为止，我相信我已经覆盖了1-3个，属于第4部分。

Option Explicit
Const MYPATH As String = "C:\USERS\3658\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的值放在“当前”工作簿中。

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

我发现，陈沛聪的职位的这种变化大有帮助。
就像我想要的一样，谢谢。

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