Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Excel виснет при выполнении макроса на перемножение. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Excel виснет при выполнении макроса на перемножение. (Макросы/Sub)
Excel виснет при выполнении макроса на перемножение.
Yoshe Дата: Вторник, 12.06.2018, 14:37 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Добрый день!

Занимаюсь тем, что перерабатываю рекламные кампании в Директе.
Столкнулся с необходимостью снизить CPC, поэтому озадачился перемножением ключевых запросов, чтобы расширить воронку.

Перемножать решил в excel при помощи макроса.
Нашел подходящий макрос.

И всё бы ничего. Но эксель намертво виснет при попытке получить результат перемножения х3 или х4, то есть когда результатом перемножения будет создание 100+ тысяч строк с ключевыми фразами. До 100тыс. строк всё множится окей. Но вот последнее перемножени выдает 462тыс. возможных фраз. Соответственно по макросу они записываются в столбик в каждой строчке.

Не знаю что делать, помогите :-)

Макрос: [vba]
Код
Sub ПеремножитьФразы()
Dim Arr As Variant
Dim ResultArr As Variant
Dim ResultLenArr As Variant
Dim r, r1, r2 As Range
Dim Col As Range
Dim ColName As String
Dim ColNames As Range
Dim sColNames As String
Dim s As Range
Dim FraseTable As Range
Dim ResultCount As Long
Dim FirstCell As Range
Dim MTable As Range

Set MTable = Range("ЧтоНаЧтоПеремножаем")

Set FraseTable = Range("ТаблицаФраз")
For j = 1 To FraseTable.Columns.Count
sColNames = sColNames & FraseTable.Cells(0, j).Value & vbLf
Next

'сначала посчитаем сколько получится записей в результате перемножения
ResultCount = 0
For RowNumber = 1 To MTable.Rows.Count
Set r = MTable.Cells(RowNumber, 1)

Arr = Split(r.Value, "*")

'удаляем лишние пробелы
For i = LBound(Arr) To UBound(Arr)
Arr(i) = Trim(Arr(i))
Next

RowResultCount = 0
For i = LBound(Arr) To UBound(Arr)
ColName = "ТаблицаФраз[" & Arr(i) & "]"
If Not RangeExist(ColName) Then
r.Select
Msg = "Колонки с заголовком """ & Arr(i) & """ не существует " & vbLf & _
"Ваша таблица фраз состоит из следующих колонок: " & vbLf & _
sColNames & _
"Пожалуйста, используйте только эти названия или переименуйте одну из колонок в """ & Arr(i) & """."
MsgBox (Msg)
Exit Sub
Else
Set Col = Range(ColName)
RowCount = Application.CountA(Col)
If RowCount > 0 Then
If RowResultCount = 0 Then
RowResultCount = 1
End If
RowResultCount = RowResultCount * RowCount
End If
End If
Next
ResultCount = ResultCount + RowResultCount
Next

If ResultCount > 1048570 Then
MsgBox ("В результате перемножения получится " & ResultCount & " фраз, а Excel позволяет иметь на листе только 1048570 строк. Пожалуйста сократите количество перемножаемых колонок")
Exit Sub
End If
If MsgBox("В результате перемножения получится " & ResultCount & " фраз. Продолжить?", vbYesNo) = vbYes Then
'определяем есть ли какой либо результат
Answer = vbYes

Set r1 = Range("ЗаголовокРезультата")
Set FirstCell = r1.Offset(1, 0)
If FirstCell.Value <> "" Then
Answer = MsgBox("Заменить результат или дописать в конец результата: " & vbLf & _
"Да - заменить существующий результат на новый" & vbLf & _
"Нет - дописать результат перемножения фраз в конец имеющегося результата" & vbLf & _
"Отмена - ничего не делать", vbYesNoCancel)
End If
If Answer = vbCancel Then
Exit Sub
End If
If Answer = vbNo Then
Set FirstCell = Cells(Rows.Count, FirstCell.Column).End(xlUp)
If ResultCount + FirstCell.Row > 1048576 Then
MsgBox ("Дописать результат не получится, т.к. суммарно с предыдущим результатом получится " & (ResultCount + FirstCell.Row) & " фраз, а Excel позволяет иметь на листе только 1048570 строк. Пожалуйста сократите количество перемножаемых колонок или выберите ""Да"" чтобы перезаписать результат")
Exit Sub
End If
Set FirstCell = FirstCell.Offset(1, 0)
ElseIf Answer = vbYes Then 'очистить колонку результатов
Set r2 = Range(FirstCell, Cells(Rows.Count, FirstCell.Column).End(xlUp))
r2.Clear
End If

'перемножаем
For RowNumber = 1 To MTable.Rows.Count
Set r = MTable.Cells(RowNumber, 1)
If Trim(r.Value) <> "" Then
Arr = Split(r.Value, "*")

'удаляем лишние пробелы
For i = LBound(Arr) To UBound(Arr)
Arr(i) = Trim(Arr(i))
Next

Call ПеремножитьНаКолонки("", Arr, FirstCell)
End If
Next

End If
End Sub

Sub ПеремножитьНаКолонки(Фраза As String, МассивНазванийКолонок As Variant, ByRef КудаВставлять As Range)
Dim МассивДальше() As Variant
Dim r As Range
Dim RowOffset
Dim НоваяФраза As String

' If МассивНазванийКолонок Is Empty Then
' Exit Sub
' End If

If UBound(МассивНазванийКолонок) > 0 Then
ReDim МассивДальше(UBound(МассивНазванийКолонок) - 1)
For i = LBound(МассивНазванийКолонок) + 1 To UBound(МассивНазванийКолонок)
МассивДальше(i - 1) = МассивНазванийКолонок(i)
Next
End If

Set r = Range("ТаблицаФраз[" & МассивНазванийКолонок(0) & "]")
RowOffset = 0
For i = 1 To r.Cells.Count
s = Trim(r.Cells(i, 1).Value)
If s <> "" Then
RowOffset = RowOffset + 1
If Фраза <> "" Then
НоваяФраза = Фраза & " " & s
Else
НоваяФраза = s
End If
If UBound(МассивНазванийКолонок) = 0 Then 'нужно выводить
row1 = КудаВставлять.Row
КудаВставлять.Value = НоваяФраза
Set КудаВставлять = КудаВставлять.Offset(1, 0)
row2 = КудаВставлять.Row
Else 'рекурсивно вызываем дальше
Call ПеремножитьНаКолонки(НоваяФраза, МассивДальше, КудаВставлять)
End If
End If
Next

End Sub

Function RangeExist(rName As String) As Boolean
Dim r As Range
On Error Resume Next
Set r = Range(rName)
RangeExist = Not r Is Nothing
End Function
[/vba]


www.remont-mebel.pro

Сообщение отредактировал Yoshe - Среда, 13.06.2018, 13:09
 
Ответить
СообщениеДобрый день!

Занимаюсь тем, что перерабатываю рекламные кампании в Директе.
Столкнулся с необходимостью снизить CPC, поэтому озадачился перемножением ключевых запросов, чтобы расширить воронку.

Перемножать решил в excel при помощи макроса.
Нашел подходящий макрос.

И всё бы ничего. Но эксель намертво виснет при попытке получить результат перемножения х3 или х4, то есть когда результатом перемножения будет создание 100+ тысяч строк с ключевыми фразами. До 100тыс. строк всё множится окей. Но вот последнее перемножени выдает 462тыс. возможных фраз. Соответственно по макросу они записываются в столбик в каждой строчке.

Не знаю что делать, помогите :-)

Макрос: [vba]
Код
Sub ПеремножитьФразы()
Dim Arr As Variant
Dim ResultArr As Variant
Dim ResultLenArr As Variant
Dim r, r1, r2 As Range
Dim Col As Range
Dim ColName As String
Dim ColNames As Range
Dim sColNames As String
Dim s As Range
Dim FraseTable As Range
Dim ResultCount As Long
Dim FirstCell As Range
Dim MTable As Range

Set MTable = Range("ЧтоНаЧтоПеремножаем")

Set FraseTable = Range("ТаблицаФраз")
For j = 1 To FraseTable.Columns.Count
sColNames = sColNames & FraseTable.Cells(0, j).Value & vbLf
Next

'сначала посчитаем сколько получится записей в результате перемножения
ResultCount = 0
For RowNumber = 1 To MTable.Rows.Count
Set r = MTable.Cells(RowNumber, 1)

Arr = Split(r.Value, "*")

'удаляем лишние пробелы
For i = LBound(Arr) To UBound(Arr)
Arr(i) = Trim(Arr(i))
Next

RowResultCount = 0
For i = LBound(Arr) To UBound(Arr)
ColName = "ТаблицаФраз[" & Arr(i) & "]"
If Not RangeExist(ColName) Then
r.Select
Msg = "Колонки с заголовком """ & Arr(i) & """ не существует " & vbLf & _
"Ваша таблица фраз состоит из следующих колонок: " & vbLf & _
sColNames & _
"Пожалуйста, используйте только эти названия или переименуйте одну из колонок в """ & Arr(i) & """."
MsgBox (Msg)
Exit Sub
Else
Set Col = Range(ColName)
RowCount = Application.CountA(Col)
If RowCount > 0 Then
If RowResultCount = 0 Then
RowResultCount = 1
End If
RowResultCount = RowResultCount * RowCount
End If
End If
Next
ResultCount = ResultCount + RowResultCount
Next

If ResultCount > 1048570 Then
MsgBox ("В результате перемножения получится " & ResultCount & " фраз, а Excel позволяет иметь на листе только 1048570 строк. Пожалуйста сократите количество перемножаемых колонок")
Exit Sub
End If
If MsgBox("В результате перемножения получится " & ResultCount & " фраз. Продолжить?", vbYesNo) = vbYes Then
'определяем есть ли какой либо результат
Answer = vbYes

Set r1 = Range("ЗаголовокРезультата")
Set FirstCell = r1.Offset(1, 0)
If FirstCell.Value <> "" Then
Answer = MsgBox("Заменить результат или дописать в конец результата: " & vbLf & _
"Да - заменить существующий результат на новый" & vbLf & _
"Нет - дописать результат перемножения фраз в конец имеющегося результата" & vbLf & _
"Отмена - ничего не делать", vbYesNoCancel)
End If
If Answer = vbCancel Then
Exit Sub
End If
If Answer = vbNo Then
Set FirstCell = Cells(Rows.Count, FirstCell.Column).End(xlUp)
If ResultCount + FirstCell.Row > 1048576 Then
MsgBox ("Дописать результат не получится, т.к. суммарно с предыдущим результатом получится " & (ResultCount + FirstCell.Row) & " фраз, а Excel позволяет иметь на листе только 1048570 строк. Пожалуйста сократите количество перемножаемых колонок или выберите ""Да"" чтобы перезаписать результат")
Exit Sub
End If
Set FirstCell = FirstCell.Offset(1, 0)
ElseIf Answer = vbYes Then 'очистить колонку результатов
Set r2 = Range(FirstCell, Cells(Rows.Count, FirstCell.Column).End(xlUp))
r2.Clear
End If

'перемножаем
For RowNumber = 1 To MTable.Rows.Count
Set r = MTable.Cells(RowNumber, 1)
If Trim(r.Value) <> "" Then
Arr = Split(r.Value, "*")

'удаляем лишние пробелы
For i = LBound(Arr) To UBound(Arr)
Arr(i) = Trim(Arr(i))
Next

Call ПеремножитьНаКолонки("", Arr, FirstCell)
End If
Next

End If
End Sub

Sub ПеремножитьНаКолонки(Фраза As String, МассивНазванийКолонок As Variant, ByRef КудаВставлять As Range)
Dim МассивДальше() As Variant
Dim r As Range
Dim RowOffset
Dim НоваяФраза As String

' If МассивНазванийКолонок Is Empty Then
' Exit Sub
' End If

If UBound(МассивНазванийКолонок) > 0 Then
ReDim МассивДальше(UBound(МассивНазванийКолонок) - 1)
For i = LBound(МассивНазванийКолонок) + 1 To UBound(МассивНазванийКолонок)
МассивДальше(i - 1) = МассивНазванийКолонок(i)
Next
End If

Set r = Range("ТаблицаФраз[" & МассивНазванийКолонок(0) & "]")
RowOffset = 0
For i = 1 To r.Cells.Count
s = Trim(r.Cells(i, 1).Value)
If s <> "" Then
RowOffset = RowOffset + 1
If Фраза <> "" Then
НоваяФраза = Фраза & " " & s
Else
НоваяФраза = s
End If
If UBound(МассивНазванийКолонок) = 0 Then 'нужно выводить
row1 = КудаВставлять.Row
КудаВставлять.Value = НоваяФраза
Set КудаВставлять = КудаВставлять.Offset(1, 0)
row2 = КудаВставлять.Row
Else 'рекурсивно вызываем дальше
Call ПеремножитьНаКолонки(НоваяФраза, МассивДальше, КудаВставлять)
End If
End If
Next

End Sub

Function RangeExist(rName As String) As Boolean
Dim r As Range
On Error Resume Next
Set r = Range(rName)
RangeExist = Not r Is Nothing
End Function
[/vba]

Автор - Yoshe
Дата добавления - 12.06.2018 в 14:37
boa Дата: Вторник, 12.06.2018, 15:34 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 167
Репутация: 27 ±
Замечаний: 0% ±

2013, 365
Yoshe, вы прикладываете обрывок модуля класса и просите помочь с макросом...
а где же макрос?


 
Ответить
СообщениеYoshe, вы прикладываете обрывок модуля класса и просите помочь с макросом...
а где же макрос?

Автор - boa
Дата добавления - 12.06.2018 в 15:34
Yoshe Дата: Среда, 13.06.2018, 12:27 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
boa, прошу прощения.
Постарался исправить. Не знаю как извлечь файл с макросом, поэтому исправил свой пост

Сам файл с перемножением весит 2мб, поэтому добавить не получается ((


www.remont-mebel.pro

Сообщение отредактировал Yoshe - Среда, 13.06.2018, 13:08
 
Ответить
Сообщениеboa, прошу прощения.
Постарался исправить. Не знаю как извлечь файл с макросом, поэтому исправил свой пост

Сам файл с перемножением весит 2мб, поэтому добавить не получается ((

Автор - Yoshe
Дата добавления - 13.06.2018 в 12:27
_Boroda_ Дата: Среда, 13.06.2018, 12:34 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13187
Репутация: 5422 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
- Прочитайте Правила форума
- Исправьте название темы согласно п.2 Правил форума
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле)
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение- Прочитайте Правила форума
- Исправьте название темы согласно п.2 Правил форума
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле)
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)

Автор - _Boroda_
Дата добавления - 13.06.2018 в 12:34
Yoshe Дата: Среда, 13.06.2018, 13:06 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
- Исправьте название темы согласно п.2 Правил форума


Но я не знаю как еще можно описать свою проблему. У меня виснет excel при выполнении макроса на перемножение. Если вы знаете как лучше сформулировать, буду благодарен за подсказку.

- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле)


Файл весит 1,2мб. даже пустой без моих данных. Как его сделать 100кб не совсем понимаю. Как вычленить сам макрос, я не понимаю.

- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)


Исправил, добавил макрос


www.remont-mebel.pro
 
Ответить
Сообщение
- Исправьте название темы согласно п.2 Правил форума


Но я не знаю как еще можно описать свою проблему. У меня виснет excel при выполнении макроса на перемножение. Если вы знаете как лучше сформулировать, буду благодарен за подсказку.

- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле)


Файл весит 1,2мб. даже пустой без моих данных. Как его сделать 100кб не совсем понимаю. Как вычленить сам макрос, я не понимаю.

- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)


Исправил, добавил макрос

Автор - Yoshe
Дата добавления - 13.06.2018 в 13:06
boa Дата: Среда, 13.06.2018, 13:21 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 167
Репутация: 27 ±
Замечаний: 0% ±

2013, 365
Yoshe,
Файл весит 1,2мб. даже пустой без моих данных. Как его сделать 100кб не совсем понимаю.

Сохраните файл в бинарном формате (.xlsb) или сожмите архивом


 
Ответить
СообщениеYoshe,
Файл весит 1,2мб. даже пустой без моих данных. Как его сделать 100кб не совсем понимаю.

Сохраните файл в бинарном формате (.xlsb) или сожмите архивом

Автор - boa
Дата добавления - 13.06.2018 в 13:21
Yoshe Дата: Среда, 13.06.2018, 13:42 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
boa,
Сохраните файл в бинарном формате (.xlsb) или сожмите архивом


Ну, 226кб получается как ни крути ((


www.remont-mebel.pro
 
Ответить
Сообщениеboa,
Сохраните файл в бинарном формате (.xlsb) или сожмите архивом


Ну, 226кб получается как ни крути ((

Автор - Yoshe
Дата добавления - 13.06.2018 в 13:42
boa Дата: Среда, 13.06.2018, 13:56 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 167
Репутация: 27 ±
Замечаний: 0% ±

2013, 365
Yoshe,
попробуйте погуглить "уменьшить размер файла Excel"


 
Ответить
СообщениеYoshe,
попробуйте погуглить "уменьшить размер файла Excel"

Автор - boa
Дата добавления - 13.06.2018 в 13:56
SLAVICK Дата: Среда, 13.06.2018, 14:28 | Сообщение № 9
Группа: Модераторы
Ранг: Старожил
Сообщений: 2272
Репутация: 750 ±
Замечаний: 0% ±

2007,2010,2013,2016
226кб получается как ни крути ((

так положите в архив и сохраните с разбитием на части - получится 2-3 части - сюда можно положить две части в 1-м сообщении.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
226кб получается как ни крути ((

так положите в архив и сохраните с разбитием на части - получится 2-3 части - сюда можно положить две части в 1-м сообщении.

Автор - SLAVICK
Дата добавления - 13.06.2018 в 14:28
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Excel виснет при выполнении макроса на перемножение. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!