Страницы: 1
RSS
Бекап/Импорт отдельных нескольких листов книги
 
Здравствуйте, в книге 4 листа, у меня есть код, который сохраняет и импортит только 1 лист из книги. Помогите поправить код, что бы был бекап и так же импорт 3х последних листов с сохранением названий этих листов. Файл пример приложил.
Код:
Код
Sub Backup()
Application.ScreenUpdating = False
Dim FileName$
If MsgBox("Backup?", vbQuestion + vbYesNo, "Backup") = vbNo Then
        Exit Sub
    Else
        Application.ThisWorkbook.Sheets(2).Unprotect ("")
        On Error Resume Next
        FileName = Application.GetSaveAsFilename(".xlsx", "Excel (*.xlsx),", , , Empty)
        If FileName = "False" Then GoTo Ex
        Err.Clear: ThisWorkbook.Sheets(2).Copy: DoEvents
        If Err Then GoTo Ex
        If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
            Application.DisplayAlerts = False
            Application.EnableEvents = False
            ActiveWorkbook.SaveAs FileName, xlOpenXMLWorkbook
            ActiveWorkbook.DisplayAlerts = True
            Application.EnableEvents = True
            ActiveWorkbook.Close False
            If Err = 1004 Then GoTo Ex
            MsgBox "Created!", 64, "Backup"
        End If
    End If
Ex: Application.ThisWorkbook.Sheets(2).Protect (""), UserInterfaceOnly:=True
Application.ScreenUpdating = True
End Sub

Sub Import()
Application.ScreenUpdating = False
Dim i$, j&, k&
    If MsgBox("Replace?", vbQuestion + vbYesNo, "Import") = vbNo Then
        Exit Sub
    Else
        Application.ThisWorkbook.Sheets(2).Unprotect ("")
        On Error GoTo Ex
        Workbooks.Open FileName:=Application.GetOpenFilename
        i = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        j = ThisWorkbook.Sheets(2).UsedRange.Rows.Count + 1
        k = GetObject(i).Sheets(1).UsedRange.Rows.Count + 1
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        GetObject(i).Sheets(1).Range(Cells(2, 1), Cells(k, 197)).Copy: GetObject(i).Close
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        ThisWorkbook.Sheets(2).Activate
        ThisWorkbook.Sheets(2).Range(Cells(2, 1), Cells(j, 197)).ClearContents
        ThisWorkbook.Sheets(2).Range("A2").Select: ActiveSheet.Paste
        ThisWorkbook.Sheets(1).Activate
        Application.Caption = IIf(False = True, Empty, "")
        Application.DisplayStatusBar = False
        MsgBox "Imported!", 64, "Import"
Ex:         Application.ThisWorkbook.Sheets(2).Protect (""), UserInterfaceOnly:=True: ThisWorkbook.Save
    End If
Application.ScreenUpdating = True
End Sub
 
Бекап работает, сделал так:
Код
Sub Backup()
Application.ScreenUpdating = False
Dim wsSh, FileName$
If MsgBox("Backup?", vbQuestion + vbYesNo, "Backup") = vbNo Then
        Exit Sub
    Else
        For Each wsSh In Array(2, 3, 4)
            Sh_Unprotect Application.ThisWorkbook.Sheets(wsSh)
        Next
        On Error Resume Next
        FileName = Application.GetSaveAsFilename(".xlsx", "Excel (*.xlsx),", , , Empty)
        If FileName = "False" Then GoTo Ex
        Err.Clear: ThisWorkbook.Sheets(Array(2, 3, 4)).Copy: DoEvents
        If Err Then GoTo Ex
        If ActiveWorkbook.Worksheets.Count = 3 And ActiveWorkbook.Path = "" Then
            Application.DisplayAlerts = False
            Application.EnableEvents = False
            ActiveWorkbook.SaveAs FileName, xlOpenXMLWorkbook
            ActiveWorkbook.DisplayAlerts = True
            Application.EnableEvents = True
            ActiveWorkbook.Close False
            If Err = 1004 Then GoTo Ex
            MsgBox "Created!", 64, "Backup"
        End If
    End If
Ex: For Each wsSh In Array(2, 3, 4)
        Sh_Protect Application.ThisWorkbook.Sheets(wsSh)
    Next
    ThisWorkbook.Sheets(1).Activate
Application.ScreenUpdating = True
End Sub


Импорт сделал так:
Код
Sub Import()
Application.ScreenUpdating = False
Dim wsSh, i$, j&, k&, l As Byte
    If MsgBox("Replace?", vbQuestion + vbYesNo, "Import") = vbNo Then
        Exit Sub
    Else
        For Each wsSh In Array(2, 3, 4)
            Sh_Unprotect Application.ThisWorkbook.Sheets(wsSh)
        Next
        On Error GoTo Ex
        Workbooks.Open FileName:=Application.GetOpenFilename
        i = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        For l = 2 To 4
            j = ThisWorkbook.Sheets(l).UsedRange.Rows.Count + 1
            k = GetObject(i).Sheets(l - 1).UsedRange.Rows.Count + 1
            Application.DisplayAlerts = False
            Application.EnableEvents = False
            GetObject(i).Sheets(l - 1).Range(Cells(2, 1), Cells(k, 197)).Copy
            Application.DisplayAlerts = True
            Application.EnableEvents = True
            ThisWorkbook.Sheets(l).Activate
            ThisWorkbook.Sheets(l).Range(Cells(2, 1), Cells(j, 197)).ClearContents
            ThisWorkbook.Sheets(l).Range("A2").Select: ActiveSheet.Paste
            l = l + 1
        Next l
        GetObject(i).Close
        ThisWorkbook.Sheets(1).Activate
        Application.Caption = IIf(False = True, Empty, "")
        Application.DisplayStatusBar = False
        MsgBox "Imported!", 64, "Import"
Ex: For Each wsSh In Array(2, 3, 4)
        Sh_Protect Application.ThisWorkbook.Sheets(wsSh)
    Next
    ThisWorkbook.Save
    End If
Application.ScreenUpdating = True
End Sub

Но при импорте если убрать обработчик ошибок, получаю ошибку  1004 "Метод Paste из класса Worksheet завершен неверно". Если после строки
Код
GetObject(i).Sheets(l - 1).Range(Cells(2, 1), Cells(k, 197)).Copy

закрыть файл (GetObject(i).Close), тогда "Paste" работает, но если закрыть в конце цикла, тогда ошибка. А нужно закрыть в конце цикла чтобы скопировались все листы. Как поправить этот момент? Обновленный файл пример приложил.
 
Цитата
OSA913 написал:
GetObject(i).Sheets(l - 1).Range(Cells(2, 1), Cells(k, 197)).Copy
перед Cells надо тоже указать полностью объект. Лучше так:
Код
With GetObject(i).Sheets(l - 1)
.Range(.Cells(2, 1), .Cells(k, 197)).Copy
end with
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Может кому будет интересно, так сработало:
Код
Sub Import()
Application.ScreenUpdating = False
Dim wsSh, i$
    If MsgBox("Replace?", vbQuestion + vbYesNo, "Import") = vbNo Then
        Exit Sub
    Else
        On Error GoTo Ex
        Workbooks.Open FileName:=Application.GetOpenFilename
        i = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        ThisWorkbook.Sheets(Array(2, 3, 4)).Delete
        GetObject(i).Sheets(Array(1, 2, 3)).Copy After:=ThisWorkbook.Sheets(1)
        GetObject(i).Close
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        ThisWorkbook.Sheets(1).Activate
        MsgBox "Imported!", 64, "Import"
Ex: For Each wsSh In Array(2, 3, 4)
        Sh_Protect Application.ThisWorkbook.Sheets(wsSh)
    Next
    ThisWorkbook.Save
    End If
Application.ScreenUpdating = True
End Sub
Изменено: OSA913 - 19.05.2020 06:00:33
 
Цитата
OSA913 написал:
так сработало
Вы же вообще на другую строку как на ошибочную показывали и код был другой. Копирование диапазонов против копирования листов целиком...
Ваш код по идее должен был бы так выглядеть:
Код
Application.DisplayAlerts = False
Application.EnableEvents = False
with ThisWorkbook.Sheets(l)
    .Range(.Cells(2, 1), .Cells(j, 197)).ClearContents
end with
With GetObject(i).Sheets(l - 1)
    .Range(.Cells(2, 1), .Cells(k, 197)).Copy ThisWorkbook.Sheets(l).Range("A2")
end with
Application.DisplayAlerts = True
Application.EnableEvents = True
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Я пробовал так как вы показали, но выскакивает ошибка переменная не определена. Почему так, не смог разобраться.
Файл с "исправленным" кодом приложил.
Страницы: 1
Наверх