Авторизация

Рубрики блога


Рекомендуем



Последние комментарии

Облако тегов


Устами великих

"Странный этот мир, где двое смотрят на одно и то же, а видят полностью противоположное." © Агата Кристи

Мы Вконтакте

MS Office и VBA Рубрика содержит интересные решения, малоизвестные функции и возможности, надстройки и макросы, в общем, все то, что может сделать вашу работу в пакете программ MS Office (в первую очередь - Excel, Word, Access) более эффективной.
30
Сен

GetAnotherWorkbook - универсальная функция для работы с любой другой открытой книгой

рейтинг материал 0.0 (0) | количество просмотров 1757 | количество коментариев 0
Рассмотрим функцию, которая определяет есть ли еще открытые книги и если есть, то обращается к ней через переменную, если она одна и позволяет сделать выбор, если открыто несколько книг.
Download source

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

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

Обойти выскакивание этих ошибок можно двумя путями:

1. Простой. Просто переименовать оба файла, с которыми производится работа, в тот вид, в котором они были когда записывался макрос. Например, записывался макрос в файле с названиваем "Остаток на 01.10.13.xls", работающий с файлом "Завоз на 01.10.13.xls". Вы скопировали файлы и обозвали их также, только изменили дату в названии на текущую.

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

Способ хоть и простой, но недостатком его есть постоянные манипуляции с именами и такой макрос оправдывает себя только тогда, когда он выполняет больше работы чем бы вы успели за то время, что возитесь с именами файлов.

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

2. С программированием в VBA. Потребуется дописать дополнительный код функции, которую будет использовать наш макрос и придется переписать все ссылки на файлы в макросе на переменные, которые будет использовать функция.

Непосредственно функция:

 
Function GetAnotherWorkbook() As Workbook
 ' если в данный момент открыто две книги, то функция возвратит вторую открытую книгу
 ' Если, помимо текущей, открыто более одной книги, то предоставляется выбор
 On Error Resume Next
 Dim coll As New Collection, WB As Workbook
 For Each WB In Workbooks
 If WB.Name <> ThisWorkbook.Name Then
 If Windows(WB.Name).Visible Then coll.Add CStr(WB.Name)
 End If
 Next WB
 Select Case coll.Count
 Case 0 ' нет других открытых книг
 MsgBox "Нет других открытых книг ", vbCritical, "Function GetAnotherWorkbook"
 Case 1 ' Открыта еще только одна книга, ее и возвращаем
 Set GetAnotherWorkbook = Workbooks(coll(1))
 Case Else ' открыто несколько книг, предоставляем выбор
 For i = 1 To coll.Count
 txt = txt & i & vbTab & coll(i) & vbNewLine
 Next i
 msg = "Выберите одну из следующих открытых книг и введите ее порядковый номер:" & _
 vbNewLine & vbNewLine & txt
 res = InputBox(msg, "Открыто более двух книг", 1)
 If IsNumeric(res) Then Set GetAnotherWorkbook = Workbooks(coll(Val(res)))
 End Select
End Function

Суть функции сводится к тому, что она определяет есть ли еще открытые книги, помимо той, из которой запускается макрос. Если таких книг оказывается только одна, то по умолчанию она и берется и ее имя задается через переменную, через которую мы можем обращаться к файлу. А если таких книг две и более, то всплывающее окно предоставит выбор - какой файл указать в качестве обращаемого.

Наш простой макрос "Вася" выглядит следующим образом:


Sub Вася()
 Windows("Продажи Васи.xlsx").Activate
 Range("B4").Select
 Selection.Copy
 Windows("Файл-манипулятор (с макросами).xlsm").Activate
 Range("B3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 Windows("Продажи Васи.xlsx ").Activate
 Range("B5").Select
 Application.CutCopyMode = False
 Selection.Copy
 Windows("Файл-манипулятор (с макросами).xlsm ").Activate
 Range("C3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 Windows("Продажи Васи.xlsx ").Activate
 Range("B6").Select
 Application.CutCopyMode = False
 Selection.Copy
 Windows("Файл-манипулятор (с макросами).xlsm ").Activate
 Range("D3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
End Sub

И для того чтобы заработала наша универсальная функция нужно немного переписать код, в первую очередь, заменив имена файлов на переменные используемые в функции.


Sub CopyВася()
On Error GoTo Errors1
 Dim WS1 As Excel.Worksheet
 Dim WB As Workbook
 Set WS1 = ActiveWorkbook.ActiveSheet
 Set WB = GetAnotherWorkbook
 
 If Not WB Is Nothing Then
 MsgBox "Выбрана книга: " & WB.FullName, vbInformation
 Else
 MsgBox "Книга не выбрана", vbCritical: Exit Sub
 End If
'------Start
 WB.ActiveSheet.Range("B4").Copy
 WS1.Range("B3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 
 WB.ActiveSheet.Range("B5").Copy
 WS1.Range("C3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 
 WB.ActiveSheet.Range("B6").Copy
 WS1.Range("D3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 
'------End
 
Errors1:
If Err.Number <> 0 Then
MsgBox "Ошибка № " & Err.Number & ". Что-то не так :)"
End If

End Sub

Пример можно скачать ниже.

Download source
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]