» Excel VBA (часть 2)

Oyger
MsgBox " Row = " & Selection.Row & " Column = " & Selection.Column

GFSGF
В версиях с 95-2000 была надстройка по автосохранению, в 2003, похоже такой уже нет. Но тебе ничто не мешает написать свою. Пример, как организовать таймер в Excel можно скачать здесь. В процедуре организуешь цикл по книгам Workbooks(i).FullName, если FullName содержит ":\" (то есть уже существующая книга), то сохраняешь её

alin

Цитата:

Помогите, пожалуйста.
Имеется папка с файлами *.xls в каждом файле страницы с именем d.m (дата.месяц) на каждой странице находятся сводные данные(этой страницы): здесь
Как сделать, чтобы формировалась итоговая таблица из файлов и страниц в этих файлах такого вида за декаду, месяц, квартал, год (в отдельном файле):здесь
Например, на конец декады (месяца, квартала, года), я запускаю макрос, который просматривал в папке файлы (в них листы) и формировал отчётный файл.
Заранее благодарен.

Для всех листов всех книг из конкретного каталога это будет выглядеть примерно так (подробнее, к сожалению, времени нет разбираться). Чтобы делать выборку за определенный период надо анализировать имена файлов и листов - попробуй эти условия добавить сам.
[more=Листинг]
Код:
Public Sub MakeReport()
Application.ScreenUpdating = False

Dim PathName$, FileName$, Template$
Dim lPos As Long

PathName = "D:\test\" ' каталог для поиска
Template = PathName & "*.xls" ' шаблон (файлы *.xls)
FileName = Dir(Template) ' инициализация

Set ReportSheet = ActiveWorkbook.ActiveSheet
lPos = 1

' ищем файлы *.xls в заданном каталоге
Do While FileName <> ""
Set CurrentBook = Workbooks.Open(PathName & FileName)
For Each wSheet In CurrentBook.Worksheets
ReportSheet.Cells(lPos, 1).Value = wSheet.Name
wSheet.Range("AL23:AQ28").Copy
ReportSheet.Cells(lPos, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
lPos = lPos + 6
Next
CurrentBook.Close SaveChanges:=False
Set CurrentBook = Nothing

FileName = Dir ' переходим к следующему файлу
Loop

Set ReportSheet = Nothing

Application.ScreenUpdating = True
End Sub

нужна ваша помощь в создании макроса:
в экселе есть 3 столбца
0501    4608    ул.Большие Каменщики, д.7
нужно перевести 1 и 2 столбец в шеснатеричный с добавлением цифры в конце 1,2,3 5,6,7 цифры нужны только у 1 столбца. естественно в ообщем в шеснатеричный.
то есть с каждой строки исходного, должно получится 6 как я написал ниже:
1393120025099 ул.Большие Каменщики, д.7
1394120025099 ул.Большие Каменщики, д.7
1395120025099 ул.Большие Каменщики, д.7
1397120025099 ул.Большие Каменщики, д.7
1398120025099 ул.Большие Каменщики, д.7
1399120025099 ул.Большие Каменщики, д.7

NPC
я чего то туплю... ;-(
Цитата:

0501 4608

Поясните, пожалуйста, как из этих двух цифр получилось 1393120025099

SERGE_BLIZNUK к числу из 1 столбца добавляем каждый раз 1,2,3 5,6,7 числа, преобразовываем в шеснатеричный, затем второй столбец, но цифры не добавляем, тоже преобразовываем в шеснатеричный, объеденяем и добавляем 25099 через пробел ул.Большие Каменщики, д.7
надеюсь понятно объяснил

AndVGri
Большое спасибо

NPC
понял. что интересно, в данном топике в январе этого года была похожая задача...
Интересно, для чего это нужно... впрочем, это чистое любопытство, к делу отношения не имеет. вот решение [more=Листинг]

Код:
Sub MoveDataToHex1()
Dim i, j, Row1, Row2, ColumnOfDigit1, ColumnOfDigit2 As Long
Dim ColumnOfMainText, List2Row As Long
Row1 = ActiveSheet.UsedRange.Row
Row2 = Row1 + ActiveSheet.UsedRange.Rows.Count - 1
ColumnOfDigit1 = 1
ColumnOfDigit2 = 2
ColumnOfMainText = 3
List2Row = 1
For i = Row1 To Row2
For j = 1 To 3
Worksheets("Лист2").Cells(List2Row, 1).Value = _
Hex(Trim(Cells(i, ColumnOfDigit1).Value) & Str(j)) _
& Hex(Cells(i, ColumnOfDigit2).Value) _
& "25099 " & Cells(i, ColumnOfMainText).Value
List2Row = List2Row + 1
Next j
For j = 5 To 7
Worksheets("Лист2").Cells(List2Row, 1).Value = _
Hex(Trim(Cells(i, ColumnOfDigit1).Value) & Str(j)) _
& Hex(Cells(i, ColumnOfDigit2).Value) _
& "25099 " & Cells(i, ColumnOfMainText).Value
List2Row = List2Row + 1
Next j
Next i
End Sub

Цитата:

Интересно, для чего это нужно

SERGE_BLIZNUK ну воообщем обычная база адресов Базовых станций сотового оператора Билайн (250-99), из Экселя переделывается под под формат базы программы CellTrack (нет-монитор) для смартфона. цифры 1,2,3 5,6,7 это сектора к номеру индетификатору Базовой станции из 1 столбца, а 2 столбец это код региона, 3 столбец конечно же адрес расположения базовой станции.

Добавлено:
SERGE_BLIZNUK спасибо огромное! работает! только бывают случаи что в исходнике во 2 столбце стоит 0, тогда в полученном файле можно сделать 0000, так же и 3 столбце не бывает описания, например станция в розыске, можно ставить тоже 0.

NPC
Цитата:

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

да без проблем... [more=Листинг]
Код:

Sub MoveDataToHex2()
Dim i, j, Row1, Row2, ColumnOfDigit1, ColumnOfDigit2 As Long
Dim ColumnOfMainText, List2Row As Long
Dim Hex2, Mesto As String
Row1 = ActiveSheet.UsedRange.Row
Row2 = Row1 + ActiveSheet.UsedRange.Rows.Count - 1
ColumnOfDigit1 = 1
ColumnOfDigit2 = 2
ColumnOfMainText = 3
List2Row = 1
For i = Row1 To Row2
' проверка на пустоту столбца 2
If IsEmpty(Cells(i, ColumnOfDigit2)) Then
Hex2 = "0000"
Else
If Cells(i, ColumnOfDigit2).Value = 0 Then
Hex2 = "0000"
Else
Hex2 = Hex(Cells(i, ColumnOfDigit2).Value)
End If
End If

' проверка на пустоту местоположения/описания
If IsEmpty(Cells(i, ColumnOfMainText)) Then
Mesto = "0"
Else
Mesto = Cells(i, ColumnOfMainText).Value
End If

For j = 1 To 3
Worksheets("Лист2").Cells(List2Row, 1).Value = _
Hex(Trim(Cells(i, ColumnOfDigit1).Value) & Str(j)) _
& Hex2 & "25099 " & Mesto
List2Row = List2Row + 1
Next j
For j = 5 To 7
Worksheets("Лист2").Cells(List2Row, 1).Value = _
Hex(Trim(Cells(i, ColumnOfDigit1).Value) & Str(j)) _
& Hex2 & "25099 " & Mesto
List2Row = List2Row + 1
Next j
Next i
End Sub

Нужна помощь в командах.
Есть модуль. Расчеты в нем оптимизированы до максимума, но считается очень долго. Ищу команды (тапа отключения обновления экрана), которые позволят увеличить скорость расчетов.
Напишите что знаеть. Если не трудно - команду и что она делает.
Спасибо.

Oyger

Цитата:

тапа отключения обновления экрана

Application.ScreenUpdating = False
... расчёты ...
Application.ScreenUpdating = True

+ сделайте профилирование - и посмотрите на что именно тратится время в расчётах...
(сразу скажу - тулзы для этого я не знаю, могу предложить только руками выводить временные метки в определённый лог журнал (текстовое поле, ячейки и т.п....))

Цитата:

сделайте профилирование - и посмотрите на что именно тратится время в расчётах...

Повторяю еще раз. Я знаю куда и как уходит время. Знаю сколько занимает времени обработка той или иной части. Все по максимуму оптимизированно (в силу своих возможностей, конечно. Может кто и еще лучше смог бы). Я теперь ищу пути оптимизации, не зависящие от расчетов. Как пример: отключене обновление экрана - это я делать умею.
Вот и спрашиваю, может еще кто-нибудь что-нибудь знает. Надо убыстрять работу...
Поделитесь знаниями, люди.

Oyger
Ну, если всё знаешь, так что советовать? Пиши дополнение к Excel на чём-нибудь серьёзном, в VS2003-2005 есть заготовки для написания расширений. Отключи автоматический пересчёт на листах, реакцию Excel на события, работай не с ячейками напрямую, а бери данные из них в массив, и результаты выгружай массивом, используй шаблоны страниц для ускорения форматирования...

Цитата:

реакцию Excel на события

А можно про это поподробнее? Что за штука и как работает?

Прога на VBA написана в Excel-2000
Запускают ее в Excel-XP. Выполняться отказывается. Ругается на несоответствие библиотек.

Руками правим все в экселевском VBA дизайнере (Tools->References) и все работает.
Вопрос. Можно-ли делать такие замены автоматом в зависимости от версии екселя, который эту прогу загружает?
Различия тока в номерах версий, и всё. Например MS Word 10.0 Object Library заменять на MS Word 11.0 Object Library, и наоборот.
Имеется ли какой-нить аналог IFDEF и т.п?

Oyger
[more=Подробнее]
EnableEvents Property
Applies To Application object

True if events are enabled for the specified object. Read/write Boolean.

Example
This example disables events before a file is saved so that the BeforeSave event doesn’t occur.

Application.EnableEvents = False
ActiveWorkbook.Save
Application.EnableEvents = True
[/more]
i1k
Подключи Microsoft Visual Basic for Application Extensibility, там есть коллекция References, попробуй с ней.

Это чтобы с одним экселевским файлом, тащить еще и отдельные библиотеки?
Проблема собсно в том, что я прогу написал в ХРшном екселе, но когда она разошлась по всей стране, выяснилось, что народ местами сидит еще на 2000. Есно при выполнении, и в частности при экспорте в ворд, прога ругается и просит подать ей именно 11.0 библиотеку работы с вордом. А если вручную поменять на 10.0 версию (которая идет с 2000), работает и на 2000 как ни в чем ни бывало.
Хотелось бы на этапе загрузки определять в какой версии прога собирается выполняться, и подсовывать ей ссылку на соответствующую библиотеку. Она же компилируется тока когда загружается ..
Вроде как, на пример в паскале:

Код: uses
{$IFDEF EH_LIB_6} Variants, {$ENDIF} DbUtilsEh, DBGridEh,

i1k
Проверить, жаль не могу - одна версия Excel у меня, но, если попробовать в событии открытия книги проверить и установить нужную версию? (Указанная выше библиотека для VBEIDE входит в Office 2000)

Код:
Public Sub test()
Dim pApp As Object, pProject As Object, pReference As Object

Set pApp = GetObject(, "Excel.Application")
Debug.Print pApp.Version
Set pProject = pApp.ThisWorkbook.VBProject
For Each pReference In pProject.References
Debug.Print pReference.GUID
Debug.Print pReference.Name
Debug.Print pReference.Major
Next pReference
End Sub

хм, мысль... надо попробовать. ВМваре поставить чтоль, для экспериментов...
Я вот подумывал над поздним связыванием, но инфы не хватает...
Спасибо за идею!

i1k
Сообщи, будь добр, вышло или нет? Вдруг в хозяйстве пригодится?

i1k имхо позднее связывание завсегда лучше

i1k

Какое связывание используешь?
Если раннее - может в этом и есть твой клин. Попробуй перейти на позднее.

2Oyger
да по всей вероятности раннее и использую Т.к. пока не знаю как использовать в ВБА позднее. Опять таки вопрос, библиотеки (в частности вордовская) подключаются по имени или по GUID? И если есть примерчик, буду просто счастлив!

jONES1979
а то!

2AndVGri
тестинг затягивается ВМВАре отказывается ставиться, а 2 офиса на одной машине - мне даже представить сложно как это будет выглядеть )

по GUID - это и будет раннее связвание, так как они генерятся для каждой библиотеки, для каждой версии(каждой подверсии(каждой под.подверсии)) свои...

на скока я представляю - позднее связывание, эт когда библиотке вообще не подключаешь. объекты создаешь через CreateObject(), GetObject() , константы "именуешь заново", в общем всё как в VBS, если сталкивался.

i1k

Да уже AndVGri написал. Повторюсь.

Пример раннего связывания:

Dim objWord as Word.Applocation
Set objWord = New Word.Application
...
objWord.Quit

Позднее связывание может работать как со ссылкой на библеотеку типов сервера автоматизации, так и без нее. А для раннего такая ссылка обязательна.

Пример позднего связывания:

Dim objWord as Object
Set objWord = GetObject ("", "Word.Application")
...
objWord.Quit

Код:
Set wordObj = CreateObject("word.Application")
ChDir Application.ActiveWorkbook.Path
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(Application.ActiveWorkbook.Path + "\" + WordTemplate) Then
wordObj.Application.Documents.Add (Application.ActiveWorkbook.Path + "\" + WordTemplate)
ElseIf fs.FileExists(Application.TemplatesPath + WordTemplate) Then
wordObj.Application.Documents.Add (Application.TemplatesPath + WordTemplate)
Else:.....

i1k


Цитата:

это то что у меня, т.е. именно раннее

Ты не прав. CreateObject это тоже позднее связывание

Слушай, а ты библеотеку подключаешь через меню в Tools -> References???

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

ну как... Когда писал все это дело, то как-то не вдавался в подробности...
А вот потом народ начал жаловаться что в старых версиях (2К) не работает.. То бишь сверху вниз нет связки..
Тогда я и задался этим вопросом...

Исправлять приходится руками именно через tools->references
В появившемся окне необходимо найти строку начинающуюся со слова "MISSING"
убрать галочку в начале этой строки, и далее в списке найти строку Microsoft Word N Object Library, где Nравно
9.0 - для использования в MS Office 2000
10.0 - для использования в MS Office XP (2002)
11.0 - для использования в MS Office 2003

Для простой машинистки - это просто неподъемная задача, как бы детально я ее не расписывал в мануале

Как бороться средствами самого Офиса?