Занимаюсь тем, что перерабатываю рекламные кампании в Директе. Столкнулся с необходимостью снизить 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]
Добрый день!
Занимаюсь тем, что перерабатываю рекламные кампании в Директе. Столкнулся с необходимостью снизить 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
- Прочитайте Правила форума - Исправьте название темы согласно п.2 Правил форума - Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле) - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
Самое главное - уберите рекламу из подписи
- Прочитайте Правила форума - Исправьте название темы согласно п.2 Правил форума - Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле) - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
Самое главное - уберите рекламу из подписи_Boroda_
- Исправьте название темы согласно п.2 Правил форума
Но я не знаю как еще можно описать свою проблему. У меня виснет excel при выполнении макроса на перемножение. Если вы знаете как лучше сформулировать, буду благодарен за подсказку.
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле)
Файл весит 1,2мб. даже пустой без моих данных. Как его сделать 100кб не совсем понимаю. Как вычленить сам макрос, я не понимаю.
- Исправьте название темы согласно п.2 Правил форума
Но я не знаю как еще можно описать свою проблему. У меня виснет excel при выполнении макроса на перемножение. Если вы знаете как лучше сформулировать, буду благодарен за подсказку.
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума (не нужно весь файл, достаточно несколько строк и, самое главное, макросы в файле)
Файл весит 1,2мб. даже пустой без моих данных. Как его сделать 100кб не совсем понимаю. Как вычленить сам макрос, я не понимаю.