» Excel VBA (часть 3)

Hugo121
да именно поэтому заменил, т.к. excel русский и слова истина-ложь в ячейках воспринимает не как текст а как boolean-значение.

Но мне показалось, что у автора как раз boolean-значение и будет, например как результат формулы. Ну в любом случае пусть автор выбирает... Но я ещё и лишние Select убрал - не нравятся они мне... лишние...

Добавлено:
ferias

Цитата:

ctSheet это таблица "st", не напишу же что ctSheet=таблица"st"?

Наверное надо ctSheet="st", по примеру

QryStr = "SELECT * FROM Имя_таблицы WHERE Имя_таблицы.поле =Kod"

Там ещё есть Namex ...

А ctTarget может быть число или слово (Integer/String)

Ну а в Экселе

Код: Set ctSheet = Sheets("st")

Hugo121
Baton34V
спасибо, у меня в ячейках не результат истина-ложь, а текст

Solenaja
Предлагаю вариант с использованием массивов. Обратите внимание на время выполнения процедуры.

Код: Sub Main()
Dim i As Long, j As Long, bi As Long, ci As Long, a(), b(), c()
a = [A4:I1100].Value: bi = 1: ci = 1
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)): ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 1) Then
For j = 1 To UBound(a, 2): b(bi, j) = a(i, j): Next: bi = bi + 1
Else
For j = 1 To UBound(a, 2): c(ci, j) = a(i, j): Next: ci = ci + 1
End If
Next
If bi > 1 Then Sheets("Истина").[A1:I1097].Value = b
If ci > 1 Then Sheets("Ложь").[A1:I1097].Value = c
End Sub

мда... разница в скорости >13 раз

Задача немного усложнилась
Есть книга с 19 листами прайсов, шапка во всех листах одинаковая (A1:M6).
Есть лист Скидки с ценовыми группами (91 строка) и соответствующими им заданными скидками.
Есть лист Содержание с наименований листов и другими данными

Строки столбца E (E7 и до конца) каждого листа прайса содержат значения наименования ценовых групп листа Скидки, иными словами каждому товару присвоена соответсвующая ценовая группа из листа Скидки или как альтернатива вообще без неё, т.е. пусто.

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

всё это конечно можно сделать через фильтр, но уж больно долго будет.

Size: 19.08MB
Download Link: hxxp://www.sendspace.com/file/b5k3op
p.s. файл с прайсом весит 19 мб из-за картинок, пароль стандартный.

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

Подсажите пожалуйста, возможно ли подгружать код из отдельного файла в процедуре VBA?
Что-то типа #include.

Например:

Sub test()

include (Application.ActiveWorkbook.Path & "\macro.bas")

End Sub

А в файле macro.bas собственно весь код который нужно выполнить.
Просто хочу держать макро в отдельных файлах.

jurris, можно:

Код: strModule = Application.ActiveWorkbook.Path & "\macro.bas")
With ThisWorkbook.VBProject.VBComponents
.Import strModule
.Remove .Item("Module1")
.Item("Лист1").CodeModule.AddFromFile Application.ActiveWorkbook.Path & "Файл.txt"
' ну и т.д.
End Sub

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

Application.Run "PERSONAL.XLS!SortDn"

Добавлено:
Solenaja

Цитата:

пароль стандартный

- у меня стандартный пароль "111". А у Вас?

Добрый день!
Прошу прошения я не много не в тему, но все-таки может здесь мне подскажут.
Подскажите пожалуйста, как вставить в PowerPoint Flash, но чтобы фон у Flash был прозрачным (может это можно сделать через макросы).
если первый вариант сделать нельзя, то как можно задать цвет фона Flash через PowerPoint?

Жентельмены, подскажите ещё по такому вопросу.
Делаю макрос. Кроме прочего он должен ячейки расчерчивать.
На сей момент там задаётся выбор области (например, А1:С4), и он её расчерчивает.

А вот как бы это сделать, чтобы он сам выбирал все непустые ячейки?

1. Количество столбцов постоянно
2. Количество строк переменно

****
Второй вопрос.
Этот же макрос красит фон некоторых ячеек жёлтым. Но после свой работы не даёт (?) пользователю, напримеР, заметить цвет раскраски. Это правится?

Hugo121
Здесь стандартный пароль - один. И это не "111"

Добавлено:
Booklet

Цитата:

А вот как бы это сделать, чтобы он сам выбирал все непустые ячейки?

Диапазон.SpecialCells(xlConstants) поможет, наверное.


Цитата:

Второй вопрос.

Что значит "не даёт"? Может быть обновление экрана отключено?
(Включить обновление - application.screenupdating=true)

Добавлено:
Solenaja
Посмотрел Ваш файл - дежа-вю какое-то... Потом вспомнил, от кого у меня такой же (ну, почти такой же ) профиль

Цитата:

Диапазон.SpecialCells(xlConstants) поможет, наверное.

...Наверное.
А можно поближе?
Вот у меня, например...

Range("A1:K19").Select

...как нужно переделать?

По второму вопросу - проверю, спасибо.

Всем доброго времени суток. Ребят, требуется ваша помощь:
Вообщем есть 2 столбца в семь строк. С помощью VBA нужно узнать чему будет равна сумма умноженных строк, то есть:
A1*B1+A2*B2+A3*B3+A4*B4+A5*B5+A6*B6+A7*B7. Только с помощью VBA...
Есть такой код:

Private Sub Command1_Click()
Dim n As Integer
Dim m As Integer
Dim A() As Integer 'матрица
Dim x() As Integer 'начальный столбец
Dim y() As Integer 'итоговый столбец y=A*x



NumRow = 2
n = 1 'количество строк матрицы
m = 7 'количество столбцов матрицы
ReDim A(1 To n, 1 To m): ReDim x(1 To m): ReDim y(1 To n)

For i = 1 To n
For j = 1 To m

A(i, j) = InputBox("введи a(" & i & "; " & j & ")")
Next j
Next i

For j = 1 To m
x(j) = InputBox("вводи b(" & j & ")")
Next j

For i = 1 To n
For j = 1 To m
y(i) = y(i) + A(i, j) * x(j)
Next j
S = S & y(i) & vbNewLine
Next i
Cells(10, 2).Value = S


'MsgBox S
End Sub

Но тут он спрашивает числа ячеек, а в моем случае значения в ячейках известны и должны оставаться такими-же.
П.С. Очень надеюсь на вашу помощь.

vlth
про профиль что-то не пойму о чем?
тот что в твоем линке ко мне никакого отношения не имеет

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


Цитата:

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

Думаю, это проще будет, чем 91 книгу делать. А что же альтернативный файл не выложили?


Добавлено:
Booklet
Например:

Код: Dim oRange as range
Set oRange = Range("A1:K19").SpecialCells(xlConstants)
If Not oRange is nothing then
For Each oCell in oRange.Cells
'Здесь что-то делаем с непустой ячейкой
Next oCell
End if

opelastr

Цитата:

С помощью VBA нужно узнать чему будет равна сумма умноженных строк

Можно существенно проще. Без всяких циклов:

Код: x = Application.SumProduct([A1:A7], [B1:B7])

SAS888
Задача-то, скорее всего, учебная, поэтому, думаю, как раз цикл нужен

Но уж если использовать функцию листа, тогда - преследуем не только упрощение кода, но и увеличение скорости его выполнения, не так ли? - логично использовать современный вариант вызова:

Код: x = Application.WorksheetFunction.SumProduct([A1:A7], [B1:B7])

Делаю поиск по нескольким листам. Если не находится на первом листе, ищу во втором и т.д. Делаю это через перехват ошибок. Первая ошибка перехватывается нормально, а вторая не перехватывается и останавливается. Что я неправильно делаю?

Код:
TxtSrch = Trim(ActiveCell.Value)
Windows("Анализ продаж.xls").Activate
Sheets("Лист1").Select
Range("A4:B4").Select
Range(Selection, Selection.End(xlDown)).Select
'Range("A4:B48").Select
Range("A4").Activate
On Error GoTo NotList1
Selection.Find(What:=TxtSrch, After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
...
NotList1:
On Error GoTo 0
Sheets("Лист2").Select
Range("A4:B4").Select
Range(Selection, Selection.End(xlDown)).Select
'Range("A4:B39").Select
Range("A4").Activate
On Error GoTo NotList2
Selection.Find(What:=TxtSrch, After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
...
NotList2:

vlth, Спасибо большое, очень выручили.
SAS888, Да, цикл нужен был..

Добрый день!
Прошу прошения я не много не в тему, но все-таки может здесь мне подскажут.
У меня есть презентация PowerPoint, и мне надо вставить в нее объект Flash (с этим проблем нет)
А проблема в том, что мне надо объект Flash при нажатии на кнопку перенести влево
спасибо за внимание

LaCastet, а так не лучше будет?

Код: Set x = Sheets(j).UsedRange.Find(TextBox1.Text, , xlValues, xlWhole)
If Not x Is Nothing Then
'нашли
Else
'не нашли
...

vlth
SAS888
так и было сделано мной на первое время. использовался метод http://www.planetaexcel.ru/tip.php?aid=184
однако из-за того, что такое большое кол-во позиций выборка происходит с задержкой до 3-7 секунд. а если ещё применить ЕОШ то вообще тупит . метод вывода "наименования" по одному столбцу только, поэтому приходится делать для вывода всей строки, ввод формулы по всем нужным столбцам.
падения производительности при пересчете всех столцов особо не наблюдается, что радует.

vlth спасибо, но что-то не то

Код: Dim oRange as range
Set oRange = Range("A1:K19").SpecialCells(xlConstants)
If Not oRange is nothing then
For Each oCell in oRange.Cells
'Здесь что-то делаем с непустой ячейкой
Next oCell
End if

Booklet
Если из модуля листа, то

Код: Range("A1:K" & Cells(Rows.Count, 2).End(xlUp).Row).Select

...не понял.
Я применил первый пример и вроде сработало.

Поясните - что есть "из модуля листа" и "иначе"?

.

Если код в листе, то лист можно не указывать. Если код в модуле или в другом листе или в другом файле - нужно указывать лист.

макрос в т.н. "личной книге макросов". То есть второй вариант? Первый вроде работает...

Код: Range("A1:K" & Cells(Rows.Count, 2).End(xlUp).Row).Select

В этой книге - тогда это будет в персонал.хлс.
Пишите ActiveWorkbook ну или я предпочитаю ранее задать книгу через "set wb ="

Cells(Rows.Count, 2).End(xlUp).Row - это в колонке 2 номер ряда с первой заполненной ячейкой, ищем снизу.

Вооще я часто использую код типа
iLastRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1
Это определяем первую снизу пустую ячейку в первой колонке, например для копирования туда данных в цикле. На каждом шаге цикла перед копированием определяем. Можно конечно счётчик поставить, но если копируется разными циклами в один лист, или неизвестно число копируемых строк, так сделать проще .

Ещё можно так:
Set blank_cell = xlsa.Cells(xlsa.[a1].SpecialCells(xlCellTypeLastCell).Row + 1, 1)
но это корректно работает на новых файлах, на поюзанных юзерами могут быть сюрпризы

Цитата:

Код:Dim oRange as range
Set oRange = Range("A1:K19").SpecialCells(xlConstants)
oRange.Copy Sheet(2).Cells(2,1)

...вообще не понял что это, если честно. Копирует ячейки? Зачем?

Booklet, а я откуда должен знать, для чего Вам это? - приведены два примера использования полученного диапазона из непустых ячеек, а что уж с ними делать -решайте сами )))

Добавлено:
Такой пример устроит?

Код: Dim oRange1 As Range, oRange2 As Range, oRange As Range

With Range("A1:C4")
On Error Resume Next
Set oRange1 = .SpecialCells(xlConstants)
Set oRange2 = .SpecialCells(xlFormulas)
On Error GoTo 0
If Not oRange1 Is Nothing Then
If Not oRange2 Is Nothing Then
Set oRange = Union(oRange1, oRange2)
Else
Set oRange = oRange1
End If
ElseIf Not oRange2 Is Nothing Then
Set oRange = oRange2
End If
End With
If Not oRange Is Nothing Then _
oRange.BorderAround , xlMedium