Блог

Поэтому я работал над сохранением листа в качестве рабочей книги по определенному пути. Когда я вставляю лист (лист 4) в новую книгу, первым листом в этой новой книге является лист 4. Это нормально, но второй лист, который не обязательно должен быть там, называется лист1 и пуст. Как я могу перезаписать лист1 в качестве листа, который я вставляю (лист4). Или можно ли удалить лист1 без появления предупреждения?

 Sub newWorkbook()

    Dim wb As Workbook
    Set wb = Workbooks.Add

    ThisWorkbook.Sheets(4).Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:the path and file"

    Sheets(2).Delete

End Sub
 

Надеюсь, кто-нибудь сможет мне помочь 🙂

Обновить:

Таким образом, рабочая книга закрывается после сохранения в пути и хорошо работает. Проблема в том, что если есть файл с тем же именем, что и тот, который я пытаюсь сохранить, то я хочу перезаписать этот файл в пути. Все еще надеюсь, что можно добавить дату к имени файла, которая должна быть датой того дня, когда он был сохранен.

Делаю это для листа 4:

 Sub saveFile1()

    Dim PathToSave

    PathToSave = "C:the paththe file name.xlsm"
    ThisWorkbook.Sheets(4).Copy
    ActiveWorkbook.SaveAs Filename:=PathToSave, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close False

End Sub
 

И то же самое сделано для листа5:

 Sub saveFile2()

    Dim PathToSave

    PathToSave = "C:the paththe file name.xlsm"
    ThisWorkbook.Sheets(5).Copy
    ActiveWorkbook.SaveAs Filename:=PathToSave, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close False

End Sub
 

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

 Sub newWorkbook()
 Dim PathToSave1 As String, PathToSave2 As String, wb As Workbook, arrSh(), shN, i As Long
    
    Set wb = ThisWorkbook
    arrSh = Array(wb.Sheets(4).Name, wb.Sheets(5).Name)
    PathToSave1 = ThisWorkbook.path amp; ""  'use here the path you need
    PathToSave2 = ThisWorkbook.path amp; "testFolder"
    For Each shN In arrSh
        wb.Sheets(shN).Copy
         i = i   1
        Application.DisplayAlerts = False
         ActiveWorkbook.saveas FileName:=IIf(i = 1, PathToSave1, PathToSave2) amp; _
                 shN amp; "_" amp; Format(Date, "dd_mm_yyyy") amp; ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
         ActiveWorkbook.Close False
        Application.DisplayAlerts = True
    Next
End Sub
 

Скопируйте один лист в Новую книгу

• Ниже приведены некоторые (те, о которых я мог подумать) сюрпризы, с которыми вы можете столкнуться при копировании одного листа в новую книгу. Некоторые из них более или менее нелепы, но все же действительны.

 Option Explicit

Sub SheetToWorkbookTEST()
    Const ProcName As String = "SheetToWorkbookTEST"
    On Error GoTo ClearError
    
    Const dFolderPath As String = "C:Test"
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sh As Object: Set sh = ActiveSheet ' wb.Sheets("Sheet4")
    SheetToWorkbook sh, dFolderPath, "File", Date

ProcExit:
    Exit Sub
ClearError:
    MsgBox "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
        amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
        amp; "        " amp; Err.Description, vbCritical, ProcName
    Resume ProcExit
End Sub

Sub SheetToWorkbook( _
        ByVal SourcSheet As Object, _
        ByVal FolderPath As String, _
        ByVal FilePattern As String, _
        ByVal FileDate As Date, _
        Optional ByVal DateFormat As String = "yyyymmdd", _
        Optional ByVal PatternDateSeparator As String = " - ", _
        Optional ByVal SheetName As String = "Sheet1")
    Const ProcName As String = "SheetToWorkbook"
    On Error GoTo ClearError
    
    Dim pTitle As String: pTitle = "Sheet to Workbook"
    
    If SourcSheet Is Nothing Then
        MsgBox "No sheet (""Nothing"").", _
            vbCritical, pTitle
        Exit Sub
    End If
    
    If TypeName(SourcSheet) <> "Worksheet" Then
        If TypeName(SourcSheet) <> "Chart" Then
            MsgBox "The first argument has to be a sheet object " _
                amp; "(""Worksheet"" or ""Chart""), yet you have chosen " _
                amp; "an object of type """ amp; TypeName(SourcSheet) amp; """.", _
                vbCritical, pTitle
            Exit Sub
        End If
    End If
    'Debug.Print TypeName(SourcSheet)
    
    If Len(Dir(FolderPath, vbDirectory)) = 0 Then
        MsgBox "The folder '" amp; FolderPath amp; "' does not exist.", _
            vbCritical, pTitle
        Exit Sub
    End If
    
    Dim aSep As String: aSep = Application.PathSeparator
    Dim dFolderPath As String
    If Right(FolderPath, 1) = aSep Then
        dFolderPath = FolderPath
    Else
        dFolderPath = FolderPath amp; aSep
    End If
    'Debug.Print dFolderPath
    
    Dim dFilePath As String
    dFilePath = dFolderPath amp; FilePattern amp; PatternDateSeparator _
        amp; Format(FileDate, DateFormat) amp; ".xlsx"
    'Debug.Print dFilePath
    
    If SourcSheet.Visible <> xlSheetVisible Then
        MsgBox "The sheet '" amp; SourcSheet.Name amp; "' is not visible. " amp; vbLf _
            amp; "You can export a single sheet to a new workbook " _
            amp; "only if it is visible.", _
            vbCritical, pTitle
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    SourcSheet.Copy
    Dim dwb As Workbook: Set dwb = ActiveWorkbook
    Dim dsh As Object: Set dsh = dwb.Sheets(1)
    If dsh.Name <> SheetName Then
        dsh.Name = SheetName
    End If
    
    Dim SaveErrNum As Long
    Application.DisplayAlerts = False ' save without confirmation
    On Error Resume Next
    dwb.SaveAs dFilePath, xlOpenXMLWorkbook
    SaveErrNum = Err.Number
    On Error GoTo ClearError ' instead of 'On Error Goto 0'
    Application.DisplayAlerts = True
    dwb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    If SaveErrNum <> 0 Then
        MsgBox "The file could not be saved as" _
            amp; vbLf amp; """" amp; dFilePath amp; """" amp; vbLf _
            amp; "Make sure the file name is valid.", _
            vbCritical, pTitle
        Exit Sub
    End If
    
    Dim msg As Long
    msg = MsgBox("Sheet '" amp; SourcSheet.Name amp; "' exported to workbook '" _
        amp; dFilePath amp; "'." amp; vbLf amp; "Do you want to browse its location?", _
        vbInformation   vbYesNo   vbDefaultButton2, pTitle)
    If msg = vbYes Then
        SourcSheet.Parent.FollowHyperlink dFolderPath
    End If
    
ProcExit:
    Exit Sub
ClearError:
    MsgBox "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
        amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
        amp; "        " amp; Err.Description
    Resume ProcExit
End Sub