» Excel VBA (часть 2)

DocBeen
А еще можно через "Сводные Таблицы". Которые тоже управляются программно. Но если я делал программно, то отсортировал бы диапазон, а потом бы прошелся в цикле подсчитывая записи. Соответственно промежуточные итоги и сводные таблицы не использовал бы ...

Например так бы:
1) Сначала сортировка вызовом соответствующей фичи из кода (как это писать - можешь увидеть записав макрос средствами ёхеля).

2) А потом вот так бы:

Код:
Set inSh = Worksheets("Лист1") 'определяем имя исходной таблицы
Set outSh = Worksheets("Лист2") 'определяем имя сводной таблицы

r1 = 2 'определяем начальную строку в исходной таблице (2 - т.к. 1-ая строка например занята шапкой)
r2 = 1 'определяем начальную строку в сводной таблице

Do While inSh.Cells(r1, 1) <> "" 'цикл по строкам исходной таблицы, до тех пор пока не закончиться НЕпустые строки в исходной таблице в 1-ой колоке (там где имя)
If inSh.Cells(r1, 1) <> inSh.Cells(r1 - 1, 1) Then 'проверка условия, что имя на предыдущей строке отличается от имени на текущей строке
r2 = r2 + 1 'если оно таки отличается, то добавление строки в сводную таблицу
outSh.Cells(r2, 1) = inSh.Cells(r1, 1) 'а также имени в сводную таблицу
outSh.Cells(r2, 2).ClearContents 'а также очищается 2-ая колонка (на всякий случай)
End If
outSh.Cells(r2, 2) = outSh.Cells(r2, 2) + inSh.Cells(r1, 2) 'суммирование цифровых значений (суммируется текущее значение текущей строки сводной таблицы и значение из исходной таблицы)
r1 = r1 + 1 'переход на новую строку в исходной таблице
Loop

SAS888

Цитата:

Не совсем понятно. Т.е. у Вас есть измененный файл (1) и старый файл без последних изменений (2). Так? Если "да", то что мешает сравнить 1 и 2 столбцы файлов (например, по строкам), и добавить и сделать все что нужно с новыми данными? А обновлять только столбец 3.

Все именно так. Мешает отсутствие знаний-)
мне нужны хотя бы примеры подобных процедур.
Буду благодарен за помощь.

Такая проблема. Когда ставлю галочку Общего доступа к книге, перестает работать метод Unprotect

ol7ca
Посмотрите пример здесь: Ссылка
Пусть файл "1.xls" - рабочий файл. Файл "2.xls" - Файл, содержащий то, что Вы требуете.
Для теста, попробуйте добавить данные в файл 1 и (или) изменить данные в столбце "C". Затем в файле 2 запустите макрос ( файл 1 должен находиться в той же директории, что и файл 2, необязательно открыт). Поэкспериментируйте с датой. Сортировка и отмена окраски должна происходить при изменении номера текущего месяца. Все ли так, как Вы хотели?

Всем привет, есть такой вопрос на знание макрсов- если можете помогите-надо срочно и нету времени во всем самому спокойно разобраться

Короче есть поле дата и поле Today, если поле Today и дата совпадают то можно вписать данные в ячейку рядом с датой, а остальные ячейки блокируются.

С уважением, Алексей

rushclub
Попробуй вот это:

Option Explicit
Private Sub Workbook_Open()
Dim rng As Range
Dim dtToday As Date ' переменная, где хранится сегодняшняя дата
' Диапазон B1:B100 содержит список дат. Если в этом диапазоне найдется дата, которая совпадает с текущей (dtToday),
' то ячейка справа от нее становится доступной для записи

dtToday = Now()
Set rng = Sheets("Лист1").Range("B1:B100").Find(what:=dtToday)
If Not rng Is Nothing Then rng.Offset(, 1).Locked = False
Sheets("Лист1").Protect
End Sub

Добавлено:
Такая проблема. Когда ставлю галочку Общего доступа к книге, перестает работать метод Unprotect

While IsError(Excel.WorksheetFunction.Find(",", cc1, index_map)) <> True
не срабатывает, просматриваю в watches и понимаю что IsError не отрабатывает, пишет что невозможно получить значение, так я и на то его поставил сюда что бы он определял когда значение получать возможно а когда нет.

vasiliy74 вот, может поможет пример кода...
Копирайт чей не помню.. но выдернуто однозначно с какого-то форума:

Код:
>уважаемые подскажите, как в листе excel найти строку со словом
> например "test" и ниже ее вставить строку со словами "test_test"?

Sub Макрос1()
Dim iRange As Range
Dim iString As String
iString = "Test"
Set iRange = ActiveSheet.UsedRange.Find(what:=iString, LookIn:=xlValues, LookAt:=xlWhole)
If iRange Is Nothing Then
MsgBox "Текст " & iString & " на листе не найден!", vbExclamation, "Ошибка"
Exit Sub
End If
Rows(iRange.Row + 1).Insert Shift:=xlDown
Cells(iRange.Row + 1, iRange.Column) = "Test-Test"
End Sub

ВОПРОС

На форме несколько CheckBox (10 штук)
Каким образом сделать следующее:
For X=1 to 10
IF CheckBox(X)= true then 'выполняем если CheckBox(х) с галкой
Next

Собственно программа ругается на выражение CheckBox(x)

Попал в затык

Есть конструкция

With Application.FileSearch
.Filename = "*" + ".xls"
.LookIn = path_2found
If .Execute > 0 Then
ffc = .FoundFiles.Count
Else
MsgBox "По заданным параметрам файлы не найдены!", vbExclamation
Exit Sub
End If
End With

На всех машинах пашет без проблем, а на одной .execute всегда возвращает 0
Как побороть - ума не приложу.
Везде стоит Excel 2003, сервис пак 3, на той машине, где не работает даже антивирус удалил - не помогло.

CEMEH
Массивов объектов в VBA нет. Поэтому самостоятельно сведи их, например, в коллекцию, а уж к её элементам и обращайся


Код:
Private pCheckCol As New Collection

Private Sub UserFrom_Activate()
Dim pCheck As MSForms.Control
For Each pCheck In Me.Controls
If TypeOf pCheck Is MSForms.CheckBox Then pCheckCol.Add pCheck
Next pCheck
End Sub

'....
For X=1 to pCheckCol.Count
IF pCheckCol(X).Value then 'выполняем если CheckBox(х) с галкой
Next
'....

SAS888

Большое спасибо! Начал тестировать. В основном все как надо. Не работает сортировка и изменение цвета с красного на черный в начале след. периода, но я постараюсь сам с этим справиться.
Еще раз спасибо.

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

Добавлено:
h1dden
Вообще-то, не понятно, как компилятор воспринимает конструкцию
Цитата:

.Filename = "*" + ".xls"

В коде я бы использовал:

Код: With Application.FileSearch
.NewSearch
.LookIn = path_2found ' Надеюсь, что путь задан корректно
.Filename = "*.xls"
.Execute
If .FoundFiles.Count = 0 Then
MsgBox "По заданным параметрам файлы не найдены!", vbExclamation
Exit Sub
End If
End With

Люди, подскажите как решить проблему.
Есть Excel'евский документ, состоящий из двух страниц. Его нужно отпечатывать на одном листе бумаги с двух сторон. Как сделать, чтобы содержимое печаталось с зеркальными полями? В простейшем случае можно было бы повесить две кнопки на лист с такими макросами:


Цитата:

Private Sub Page1Butt_Click()
With ActiveSheet.PageSetup
.LeftMargin = Application.CentimetersToPoints(3)
.RightMargin = Application.CentimetersToPoints(0.5)
End With
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1
End Sub

Private Sub Page2Butt_Click()
With ActiveSheet.PageSetup
.LeftMargin = Application.CentimetersToPoints(0.5)
.RightMargin = Application.CentimetersToPoints(3)
End With
ActiveWindow.SelectedSheets.PrintOut From:=2, To:=2, Copies:=1
End Sub

Но проблема в том, что документ будет печататься на принтере, поддерживающем двухстороннюю печать (чтобы не переворачивать листы вручную) и нужно заставить Excel "на ходу" переворачивать поля. То есть мы должны нажимать всего одну кнопку для печати этого документа.

Можно ли такое сделать и как?

SAS888

Цитата:

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

как ни тестировал - сортировка и изменение цвета не работают(
(лучше сделать, чтбы можно было изменять уже на следующий день, если можно)
и еще, из файла 1 в файл 2 должны копироваться имена ячеeк. хотя можно и в файл 2 вставить мой скрипт присвоения имен.

еще один вопрос,
как можно к числу в таком формате 20-010-90-198-456
прибавить 1 к последнему числу, чтобы получилось 20-010-90-198-457
эту замену надо делать в скрипте.

спасибо.

Добавлено:

Цитата:

сортировка и изменение цвета не работают(

я закомментировал первый оператор IF
сейчас с цветом все ОК
но сортировка не работает

DmitriC
А что мешает объединить две процедуры в одну? (не сталкивался с устройствами двусторонней печати)
ol7ca

Код:
Public Function MySum(ByVal ToValue As String, ByVal AddValue As Double) As String
MySum = Format$(CDbl(Replace(ToValue, "-", "")) + AddValue, "00-000-00-000-000")
End Function

ol7ca
Примите мои извинения.Вот исправленный файл. Добавлены упущенные ссылки на рабочую книгу и изменено условие сортировки и изменения цвета (будет происходить на следующий день).

Есть такая проблема, надо скопировать определенный диапозон ячеек и вставить в новый документ Word.

Сам, в VBA новичек и добился (с помощью примереов из шапки и книг) только выделения нажного диапозона и копирования его в буфер обмена.


Вот пример

http://slil.ru/25520149

AndVGri

Цитата:

А что мешает объединить две процедуры в одну? (не сталкивался с устройствами двусторонней печати)

Если их объединить, то принтер печатает не с двух сторон, а на двух листах.

Mint86
Если то, что нужно вставить, находится в буфере обмена, то можно добавить к Вашему коду следующее:

Код: Dim wdApp As Object, wdDoc As Object ' объявляем переменные

'Открываем Word и файл "Pattern" (позднее связывание)

Set wdApp = CreateObject("Word.Application")
On Error Resume Next

'Если шаблон "Pattern.doc" в другой папке, то прописать полный путь аргумента
'Например ...Open("C:\Temp\Pattern.doc")

Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\Pattern.doc")
If Err <> 0 Then
MsgBox "Файл Pattern не найден"
Exit Sub
End If
wdApp.Visible = True

'Вставляем в Word данные из буфера обмена

SendKeys "+{Insert}", True

'Уничтожим созданные объекты (освобождая используемую память)

Set wdApp = Nothing
Set wdDoc = Nothing

SAS888

Спасибо.


Цитата:

'Открываем Word и файл "Pattern" (позднее связывание)

Set wdApp = CreateObject("Word.Application")
On Error Resume Next

'Если шаблон "Pattern.doc" в другой папке, то прописать полный путь аргумента
'Например ...Open("C:\Temp\Pattern.doc")

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

Mint86
Тогда, наверное, так:

Код: Sub Inst()

'Предполагается, что данные для вставки находятся в буфере обмена
Dim wdApp As Object, wdDoc As Object ' объявляем переменные

'Открываем Word (позднее связывание)

Set wdApp = CreateObject("Word.Application")

'Если файл "Pattern.doc" в этой папке не существует, то создать его

On Error Resume Next
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\Pattern.doc")
If Err <> 0 Then
wdApp.Documents.Add
End If
wdApp.Visible = True

'Вставляем в Word данные из буфера обмена

SendKeys "+{Insert}", True

'Сохраняем добавленный документ в той же папке

wdApp.ActiveDocument.SaveAs Filename:=ThisWorkbook.Path & "\Pattern.doc"

'Уничтожим созданные объекты (освобождая используемую память)

Set wdApp = Nothing
Set wdDoc = Nothing

End Sub

sadmn,
Цитата:

может, тут мне поможете, наведёте на мысль,
как сделать так, чтобы определённый код (часть макроса) выполнялся при нажатии клавиши (любой) на клавиатуре?

используй сабклассинг. в шапке есть примеры.
получится, скорее, что то в таком стиле:
Код: Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)

UnHook lhwnd

End Sub

Private Sub Workbook_Open()

Dim sClassName As String
Dim sCaption As String

sClassName = "XLMAIN" ' класс окна
sCaption = "Microsoft Excel" ' заголовок окна
' Находим окно
lhwnd = FindWindowEx(0, 0, sClassName, sCaption)

sClassName = "XLDESK" ' класс окна
' Находим окно
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)

sClassName = "EXCEL7" ' класс таблицы
sCaption = ActiveWorkbook.Name ' заголовок
' Находим окно
lhwnd = FindWindowEx(lhwnd, 0, sClassName, sCaption)

Hook lhwnd

End Sub

SAS888

Спасибо. Начну тестировать.

Вы мне помогали с этим скриптом, может еще подскажете, что нужно сделать, чтобы в итоге не появлялись значения: #N/A, #VALUE!, #REF!, #DIV/0!, #NUM!, #NAME?, #NULL!и им подобные?

For i = 1 To ActiveSheet.Cells(65536, 28).End(xlUp).Row
If IsNumeric(Cells(i, 28)) And Cells(i, 28) <> "" Then
Cells(i, 2) = Cells(i, Stolb)
Cells(i, 3) = Cells(i, Stolb + Sdvig1)
Cells(i, 5) = Cells(i, Stolb + Sdvig2)
Cells(i, 12) = Application.Sum(Range(Cells(i, 28), Cells(i, Stolb)))
Cells(i, 13) = Application.Sum(Range(Cells(i, 28 + Sdvig1), Cells(i, Stolb + Sdvig1)))
Cells(i, 15) = Application.Sum(Range(Cells(i, 28 + Sdvig2), Cells(i, Stolb + Sdvig2)))


Спасибо


Добавлено:

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

еще один вопрос,
как можно к числу в таком формате 20-010-90-198-456
прибавить 1 к последнему числу, чтобы получилось 20-010-90-198-457
эту замену надо делать в скрипте чтобы потом вставить в цикл.

Спасибо

ol7ca
1. Для перехвата возникновения возможной ошибки в формуле на листе Excel используй функцию "=ЕОШИБКА(значение)". (см. справку в Excel).
В VBA используй:

Код: On Error Resume Next
'Оператор (функция), выполнение которого может
'вызвать ошибку
If Err <> 0 Then
'Оператор (группа операторов), при ошибке
Else
'Оператор (группа операторов), если ошибка не возникла
End If

Как перебрать однотипные элементы активх на форме?

visual73
Например, создать из них коллекцию. Смотри пример на предыдущей странице от AndVGri

Люди, здравствуйте! =)

Скажите плиз, можно ли добавить кнопочку или функцию, чтобы одним махом снять ВСЕ фильтры?

А то тетки у меня в отделе понаставят фильтров, отсортируют данные и дальше забивают инфу. Вот и получется каша в документе.

Как их все снять СРАЗУ?

SAS888
А почему не работает такая конструкшн?

Код: If TypeOf RfEd Is MSForms.RefEdit Then

AdUser
Здесь Zorro2005 ответил.