Да не вопрос.
Требуемые функции:
Option Explicit
Function SheetExist(SheetName As String) As Boolean
' Returns TRUE if the worksheet is exist
On Error Resume Next
With Worksheets(SheetName): End With
SheetExist = (Err = 0)
End Function
Function IsWorkbookOpen(wbname As String) As Boolean
' Returns TRUE if the workbook is already opened
On Error Resume Next
With Workbooks(wbname): End With
IsWorkbookOpen = (Err = 0)
End Function
Function GetWorkbookName(wbPathName As String) As String
'Возвращает имя книги из полного маршрута
Dim Position As Integer
Position = CountSimbol(wbPathName, "\")
GetWorkbookName = Substring(wbPathName, "\", Position + 1)
End Function
Function FileExists(iFileName As String) As Boolean
' Возвращает ИСТИНА, если файл существует
FileExists = CreateObject("Scripting.FileSystemObject").FileExists(iFileName)
End Function
Function PathExists(pname) As Boolean
' Возвращает ИСТИНА, если путь существует
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Фрагмент процедуры:
With ThisWorkbook
SourceSheetName = .ActiveSheet.Name
TargetSheetName = .Worksheets("$$$").Cells(6, 1).Value
With .Sheets(SourceSheetName)
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set Mark = .Range(.Cells(2, 5), .Cells(LastRow, 5)).Find("вып")
End With
If Mark Is Nothing Then
Replica = MsgBox("Помеченные строки отсутствуют. Действие отменено", vbInformation, "Ошибка"): End
Else
Replica = MsgBox("Скопировать помеченные строки из текущего листа?", _
vbYesNo + vbQuestion + vbDefaultButton2, "Подтверждение")
If Replica = vbNo Then Exit Sub
End If
Call TurnOffScreen
FilePath = .Worksheets("$$$").Cells(2, 1).Value
ShortArchiveName = .Worksheets("$$$").Cells(4, 1).Value
If FileExists(FilePath & "\" & ShortArchiveName) = False Then
Replica = MsgBox("Файл " & ShortArchiveName & " по маршруту " & FilePath & " не найден. Будем искать?", _
vbYesNo + vbQuestion + vbDefaultButton2, "Подтверждение")
If Replica = vbYes Then
Dim FD As FileDialog
Dim iFileName As String
Dim Book As Workbook
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Filters.Clear
.Filters.Add "Microsoft Excel files", "*.xls"
.Filters.Add "All files", "*.*"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.path
.Title = "Открытие документа"
.ButtonName = "Открыть"
If .Show = False Then
MsgBox "Вы не указали файл - источник!", 48, "Ошибка"
Exit Sub
Else
iFileName = .SelectedItems(1)
End If
End With
Set FD = Nothing
ShortArchiveName = GetWorkbookName(iFileName)
'Проверка - открыт ли выбранный файл
If IsWorkbookOpen(ShortArchiveName) = False Then
Set Book = Workbooks.Open(FileName:=iFileName, UpdateLinks:=False)
Else
Replica = MsgBox("Файл с именем `" & ShortArchiveName & "` уже открыт. Продолжить?", Buttons:=vbYesNo + vbQuestion + vbDefaultButton1)
Select Case Replica
Case Is = vbNo
MsgBox "Операция прервана пользователем", 48, "Ошибка"
Call TurnOnScreen
Exit Sub
Case Is = vbYes
Set Book = Workbooks(ShortArchiveName)
End Select
End If
.Worksheets("$$$").Cells(2, 1).Value = Book.path
.Worksheets("$$$").Cells(4, 1).Value = Book.Name
FilePath = Book.path
ShortArchiveName = Book.Name
Else: Call TurnOnScreen: End
End If
Else
If IsWorkbookOpen(ShortArchiveName) = False Then
Set Book = Workbooks.Open(FileName:=FilePath & "\" & ShortArchiveName, UpdateLinks:=False)
Else
Replica = MsgBox("Файл с именем `" & ShortArchiveName & "` уже открыт. Продолжить?", Buttons:=vbYesNo + vbQuestion + vbDefaultButton1)
Select Case Replica
Case Is = vbNo
MsgBox "Операция прервана пользователем", 48, "Ошибка"
Call TurnOnScreen
Exit Sub
Case Is = vbYes
Set Book = Workbooks(ShortArchiveName)
End Select
End If
End If
Book.Activate
If SheetExist(TargetSheetName) = False Then
Worksheets.Add.Name = TargetSheetName
Worksheets(1).Visible = True
.Sheets(SourceSheetName).Rows("1:2").EntireRow.Copy
With Book.Sheets(TargetSheetName).Rows("1:2").EntireRow ' вставка строк заголовка на лист "АРХИВ"
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End If
On Error Resume Next
Book.Sheets(TargetSheetName).Unprotect
......
и далее Ваш модуль
......
End With
Лишнее сами удалите. Просто выхватил выделением, есть лишние строчки.
