Я хочу сохранить выборку как новую рабочую книгу, но если рабочая книга уже существует, я хочу сохранить ее как новую рабочую книгу в существующей рабочей книге

Question

Я все еще довольно новичок в этом.Я хочу иметь возможность сделать следующее:

1. выбрать диапазон копирования
2. вставить выделение в новую книгу
3. сохранить книгу в папке с найденным значением годав диапазоне H5 (если папка не существует, создайте ее)
4. сохранить файл как «title_month_year» значения, найденные в диапазонах A5, F5, H5 (но если файл уже существует, сохраните как новый лист / вкладка)

До сих пор я считаю, что я покрыл 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

Я немного очистил ваш код - см. Ниже. Я предположил, что значения 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 2

Я обнаружил, что этот вариант поста Пейкуна Чена очень помог.
Это работает точно так, как я хочу, спасибо.

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

Answer 3

Вы можете добавить подпункт ниже и вызвать его после 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