Синтаксис.
Объявление Программ (Sub name() .. End Sub)
и Функций
Public Function name (ByVal a as byte, b as range) as range
name = ... : End Function
Обращение к макросу: call macro_name
Области видмости Public, Private ...
Объявление массивов, циклов, переменных
типы данных
конструкции (if, switch case...)
работа со строками (mid, replace...)
спец символы (%,&,$, : и тд), комментарии ( ' )
поиск (в массиве, в строке и тп)
Диалоговые окна
Работа с директориями
Работа с SQL Server через VBA
Оптимизация
Возможные ошибки (суровое: закрывать книгу (мб с сохранением), когда выделен диапазон под копирование. снимаем by cutcopymode = false
Список готовых функций:
Действия в выделенном диапазоне для всех ячеек удовлетворяющих условию
прочее:
Запуск приложения - shell
Эмулировать нажатие клавиш - sendKey
Способы копирования
Надстройки
Поиск уникальных значений в массиве
Полезные ссылки:
https://www.whatismyip.com/ - показывает внешний IP компа
'Public str_Letter_text, str_FileFor_Letter_report_Path As String
'Public d_delivery As Date
Sub Макрос_Отчета_по_заявкам()
Const filescount As Byte = 8
Dim T As Single
T = Timer
Dim obj_Main As Object
Dim d_delivery As Date
Dim str_Letter_text$, str_FileFor_Letter_report_Path As String
Dim obj_Forma_00 As Object, fso As Object 'отключить библиотеку, обозначить как объект, Set FSO = CreateObject("Scripting.FileSystemObject")
Dim str_year_folder$, str_month_folder$, str_calc_folder$, str_voronka_folder$, str_date_voronka_folder As String
Dim str_day_crm_data_folder$, str_forma_tamplate$, LastCell$, str_Cur_Order_report$, str_Cur_Order_report_Path As String
Dim str_Forma00$, str_Forma00_path$, str_FileFor_Letter_report$, str_order_template_path As String
Dim str_prev_order_report$, str_prev_month_order_report_path As String
Dim arr_crm_forma(1 To filescount, 1 To 3) As String ' (i,1) - имя файла crm, (i,2) - путь к CRM, (i,3) - соответсвующий лист в Форме
Dim LastRow As Integer, i_last_dl%
Dim i, repday, ReportLastRow As Byte
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set obj_Main = ThisWorkbook.Sheets("Main") 'основной лист
obj_Main.Range("A9").Value = 0
'запускаем отсюда еще раз, если последний день месяца нерабочий GoTo RunOneMoreTime
RunOneMoreTime:
d_delivery = CDate(obj_Main.Range("J15"))
str_year_folder = obj_Main.Range("D21") 'папка года
str_month_folder = obj_Main.Range("D22") 'папка месяца
str_calc_folder = obj_Main.Range("D23") 'папка расчета, где лежит Форма 00
str_voronka_folder = obj_Main.Range("D24") 'папка воронки (рассылка)
str_date_voronka_folder = obj_Main.Range("D25") 'папка воронки на дату (рассылка на дату)
str_day_crm_data_folder = obj_Main.Range("D26") 'папка, где лежат выгрузки CRM
str_forma_tamplate = obj_Main.Range("D27") 'шаблон Формы
str_Forma00 = obj_Main.Range("D28") 'название формы
str_Forma00_path = obj_Main.Range("D29") 'путь к новой Форме
str_Cur_Order_report = obj_Main.Range("D30") 'название текущего отчета (который мы готовим)
str_Cur_Order_report_Path = obj_Main.Range("D31") ' тут путь текущего отчета
str_FileFor_Letter_report = obj_Main.Range("D32") 'это название файла для отправки
str_FileFor_Letter_report_Path = obj_Main.Range("D33") 'тут путь файла для отправки
str_order_template_path = obj_Main.Range("D34") 'путь к шаблону отчета по заявкам
str_prev_order_report = obj_Main.Range("D35") 'название предыдущего шаблона по заявкам
str_prev_month_order_report_path = obj_Main.Range("D36") 'месяц назад (по кол-ву рабочих дней)
str_Letter_text = "Письмо.xlsx"
If Dir(str_Forma00_path) <> "" Then
answer = MsgBox("Форма с названием " & str_Forma00 & " уже существует! Заменить (Да) или выйти (Нет)?", vbYesNo)
If answer = vbNo Then Exit Sub
End If
If Dir(str_Cur_Order_report_Path) <> "" Then
answer = MsgBox("Отчет с названием " & str_Cur_Order_report & " уже существует! Заменить (Да) или выйти (Нет)?", vbYesNo)
If answer = vbNo Then Exit Sub
End If
If Dir(str_day_crm_data_folder & "\" & obj_Main.Range("B9")) <> "" Then
answer = MsgBox("Папка с выгрузками " & obj_Main.Range("B9") & " уже существует! Заменить (Да) или выйти (Нет)?", vbYesNo)
If answer = vbNo Then Exit Sub
End If
'------------------------------------------------------------------------------------------------------
'если ПЕРВЫЙ ДЕНЬ МЕСЯЦА. Вставка планов.
If obj_Main.Range("E16") = 1 Then
'MsgBox "Не забываем добавлять планы в воронку по Регионам!!!"
plan_path = Right(str_month_folder, Len(str_month_folder) - InStrRev(str_month_folder, " ")) '"План продаж " &
plan_dir = Dir(obj_Main.Range("D20").Value & "\Планы по месяцам\" & "*" & plan_path & "*" & Right(obj_Main.Range("E13").Value, 2) & "*")
If plan_dir = "" Then MsgBox "Отсутствует план продаж. Положите в папку с планами и перезапустите макрос.": Exit Sub 'проверка наличия плана
'проверка существования папок, если их нет, то создаем
If fso.FolderExists(str_year_folder) = False Then fso.CreateFolder (str_year_folder) 'год
If fso.FolderExists(str_month_folder) = False Then fso.CreateFolder (str_month_folder) 'месяц
If fso.FolderExists(str_calc_folder) = False Then fso.CreateFolder (str_calc_folder) 'расчета
If fso.FolderExists(str_voronka_folder) = False Then fso.CreateFolder (str_voronka_folder) 'рассылка (воронка)
'копируем нужные файлы из пред.месяца
'If Dir(str_month_folder & "\" & str_prev_order_report) <> "" Then MsgBox "Файл с корректировкой плана уже существует"
FileCopy obj_Main.Range("D38").Value & "\" & str_prev_order_report, str_month_folder & "\" & str_prev_order_report 'последний отчет по заявкам
FileCopy obj_Main.Range("D38").Value & "\" & "Расчет\Корректировка плана.xlsx", str_calc_folder & "\Корректировка плана.xlsx"
FileCopy obj_Main.Range("D38").Value & "\" & "Рассылка\Макрос для регионов.xlsm", str_voronka_folder & "\Макрос для регионов.xlsm"
FileCopy obj_Main.Range("D38").Value & "\" & "Рассылка\Шаблон для отправки регионы.xlsx", str_voronka_folder & "\Шаблон для отправки регионы.xlsx"
FileCopy obj_Main.Range("D38").Value & "\" & "Рассылка\Шаблон для отправки.xlsx", str_voronka_folder & "\Шаблон для отправки.xlsx"
Workbooks.Open str_calc_folder & "\Корректировка плана.xlsx"
Set plan_corr = ActiveWorkbook
Workbooks.Open str_month_folder & "\" & str_prev_order_report
Set wb_last_prev = ActiveWorkbook
'копируем предыдущий отчет на лист "last day prev month"
wb_last_prev.Sheets("Отчет").Cells.Copy
plan_corr.Sheets("last day prev month").Cells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
' l_last_row_corr = plan_corr.Sheets("last day prev month").Cells(Rows.Count, 1).End(xlUp).Row 'там подписи есть, поэтому каркаде ищем
'находим последнюю строчку с "Каркаде" в последнем отчете прошлого месяца
l_last_row_corr = Application.Match("Каркаде", plan_corr.Sheets("last day prev month").Columns(1), 0)
'копируем первую колонку из последнего отчета на лист "Кэфы перехода" и "для вставки планов"
plan_corr.Sheets("last day prev month").Columns(1).Copy
plan_corr.Sheets("Кэфы перехода").Columns(2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
plan_corr.Sheets("Для вставки планов").Columns(2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'Копируем в отчет новые кэфы из интересов в ДЛ
plan_corr.Sheets("Кэфы перехода").Range("I5:I" & l_last_row_corr).Copy
wb_last_prev.Sheets("Отчет").Range("C5:C" & l_last_row_corr).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'копируем в отчет новые кэфы из ЛС в ДЛ
plan_corr.Sheets("Кэфы перехода").Range("J5:J" & l_last_row_corr).Copy
wb_last_prev.Sheets("Отчет").Range("AP5:AP" & l_last_row_corr).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'копируем новый план
Workbooks.Open obj_Main.Range("D20").Value & "\Планы по месяцам\" & plan_dir
Set wb_new_plan = Workbooks(plan_dir)
'копируем план на лист "иходный ПЛАН"
wb_new_plan.ActiveSheet.Cells.Copy
plan_corr.Sheets("исходный ПЛАН").Cells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
wb_new_plan.Close False
'копируем в отчет планы по сумме и количеству
plan_corr.Sheets("Для вставки планов").Range("C5:D" & l_last_row_corr).Copy
wb_last_prev.Sheets("Отчет").Range("CH5:CI" & l_last_row_corr).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'на листе "Рассылка вороки" долж обновлено, туда копирнем новые планы
l_last_row_corr = ThisWorkbook.Sheets("Рассылка воронки").Cells(Rows.Count, 1).End(xlUp).Row
plan_corr.Sheets("для вставки планов").Range("H5:H" & l_last_row_corr - 1).Value = ThisWorkbook.Sheets("Рассылка воронки").Range("A6:A" & l_last_row_corr).Value
ThisWorkbook.Sheets("Рассылка воронки").Range("I6:J" & l_last_row_corr).Value = plan_corr.Sheets("для вставки планов").Range("I5:J" & l_last_row_corr - 1).Value
'вставляем планы по регионам
Workbooks.Open str_voronka_folder & "\Макрос для регионов.xlsm"
l_last_row_corr = plan_corr.Sheets("Для вставки планов").Cells(Rows.Count, 12).End(xlUp).Row
plan_corr.Sheets("Для вставки планов").Range("L5:N" & l_last_row_corr).Copy
Workbooks("Макрос для регионов.xlsm").Sheets("Список").Range("L4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Workbooks("Макрос для регионов.xlsm").Close True
plan_corr.Save
'тут желательно вставить форму для того, чтобы пользователь проверил, норм ли всё вствилось и нажал ок
plan_corr.Close
'вставляем рабочие/нерабочие дни в главный отчет
Set wb_last_prev = wb_last_prev.Sheets("Отчет")
wb_last_prev.Activate
l_last_row_corr = Application.Match("Каркаде", wb_last_prev.Columns(1), 0)
l_last_col_corr = Application.Match("х", wb_last_prev.Rows(1), 0)
wb_last_prev.Range(Cells(5, l_last_col_corr), Cells(l_last_row_corr, l_last_col_corr)).Copy
wb_last_prev.Range(Cells(5, 6), Cells(l_last_row_corr, 36)).PasteSpecial Paste:=xlPasteFormulas
wb_last_prev.Range(Cells(5, l_last_col_corr + 39), Cells(l_last_row_corr, l_last_col_corr + 39)).Copy
wb_last_prev.Range(Cells(5, 6 + 39), Cells(l_last_row_corr, 36 + 39)).PasteSpecial Paste:=xlPasteFormulas
wb_last_prev.Range(Cells(5, l_last_col_corr + 39 + 44), Cells(l_last_row_corr, l_last_col_corr + 39 + 44)).Copy
wb_last_prev.Range(Cells(5, 6 + 39 + 44), Cells(l_last_row_corr, 36 + 39 + 44)).PasteSpecial Paste:=xlPasteFormulas
ThisWorkbook.Sheets("Праздники").Range("D5:D35").Copy
wb_last_prev.Range("F1, AS1, CK1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
Workbooks(str_prev_order_report).Save
Workbooks(str_prev_order_report).Close
Set plan_corr = Nothing
Set wb_last_prev = Nothing
Set wb_new_plan = Nothing
'обновляем коэффициенты перехода из интересов в ДЛ
DoEvents
Call change_coef
End If
Rem ----------------------------закончили вставку планов и т.п.-----------------------------------
'проверяем наличие шаблонов
'If fso.FileExists(str_order_template_path) = False Then MsgBox "Неверно указан путь к шаблону отчета по заявкам": Exit Sub 'проверка наличия шаблона отчета
If fso.FileExists(str_forma_tamplate) = False Then MsgBox "Неверно указан путь к шаблону для Формы": Exit Sub 'проверка наличия шаблона для Формы
If fso.FileExists(ThisWorkbook.path & "\" & str_Letter_text) = False Then MsgBox "Неверно указан путь к шаблону письма": Exit Sub
If fso.FileExists(str_month_folder & "\" & str_prev_order_report) = False Then MsgBox "Неверно указан путь к предыдущему отчету": Exit Sub
If fso.FileExists(str_prev_month_order_report_path) = False Then MsgBox "Неверно указан путь к отчету прошлого месяца": Exit Sub
'создает макрос с воронкой
'If FSO.FolderExists(str_date_voronka_folder) = False Then FSO.CreateFolder (str_date_voronka_folder) ' рассылка (воронка) на дату
'Грузим файлы из SQL, сохраняем якобы crm выгрузки
If obj_Main.Range("B14") = True Then
Workbooks.Open "\\fs01\userfolders\Departments\sales\sales-analitics\Отчет по заявкам\Выгрузки дня\sql выгрузки\выгрузки для отчета по заявкам.xlsb", 3
Call Application.Run("'выгрузки для отчета по заявкам.xlsb'!LoadSQLDataForOrdersReport")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Workbooks("выгрузки для отчета по заявкам.xlsb").Save
Workbooks("выгрузки для отчета по заявкам.xlsb").Close
End If
'файлы CRM выгрузок (объявляем и проверяем присутствие)
For i = 1 To filescount
arr_crm_forma(i, 1) = obj_Main.Range("H" & i + 4)
arr_crm_forma(i, 2) = str_day_crm_data_folder & "\" & arr_crm_forma(i, 1)
arr_crm_forma(i, 3) = obj_Main.Range("I" & i + 4)
If fso.FileExists(arr_crm_forma(i, 2)) = False Then
MsgBox "Файл выгрузки CRM " & obj_Main.Range("H" & i + 4) & _
" отсутствует. Работа макроса прекращена. Положите файл в папку " & _
str_day_crm_data_folder & ", тогда есть смысл перезапускать"
Exit Sub
End If
Next i
'Открываем шаблон формы
Workbooks.Open str_forma_tamplate
'If FSO.FileExists(str_Forma00_path) Then FSO.DeleteFile (str_Forma00_path)
ActiveWorkbook.SaveAs str_Forma00_path
Set obj_Forma_00 = ActiveWorkbook
obj_Forma_00.Sheets("Счет ДЛ").Range("N5") = obj_Main.Range("B9")
'удаляем старые и потом копируем данные из crm-файлов на соответствующие листы------------------------------------------
For i = 1 To filescount
If i <> 6 Then 'т.к. 5 и 6 это один и тот же лист ДОЛС, у нас на нем уже данные будут с i=5
LastRow = obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Cells.SpecialCells(xlLastCell).Row
If LastRow > 1 Then
obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Activate ' потом удалить строчку------------------------
obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Rows("2:" & LastRow).Clear 'очищаем, удалять нельзя, т.к. ссылки плывут
Else
End If
End If
If i <> 7 Then Workbooks.Open arr_crm_forma(i, 2)
'------------------------------------------------------------------
'вставляем
If i = 7 Then
Set testfile = Workbooks.Open("\\fs01\userfolders\Departments\sales\sales-analitics\Отчет по заявкам\Планы по месяцам\testfile99.xlsb", , , , "bazil")
Workbooks.Open arr_crm_forma(i, 2)
With testfile.Sheets("sheet2")
i_last_dl = .Cells(Rows.Count, 25).End(xlUp).Row '25 - столбец с номером договора
For k = i_last_dl To 1 Step -1
If obj_Main.Range("B9").Value <= .Cells(k, 25).Offset(0, 5) Then
chDL = Application.Match(.Cells(k, 25), ActiveSheet.Columns(3), 0)
If Not IsError(chDL) Then
Cells(chDL, 20) = .Cells(k, 25).Offset(0, 1)
End If
Else
Exit For
End If
Next k
End With
testfile.Close False
Set testfile = Nothing
End If
'------------------------------------------------------------------
LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell).Address
If IsEmpty(ActiveSheet.Range("A2")) Then LastCell = "A2"
Range("A2:" & LastCell).Copy
obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Activate ' потом удалить строчку----------------------
If i <> 6 Then
obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Range("A2").PasteSpecial
Else
LastRow = obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Cells(Rows.Count, 1).End(xlUp).Row
obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Range("A" & LastRow + 1).PasteSpecial
'удаляем дубликаты для ДОЛСа
obj_Forma_00.Sheets(arr_crm_forma(i, 3)).Range(Cells(1, 1), Cells()).RemoveDuplicates Columns:=1, Header:=xlYes
End If
If i = 7 Then
Range("Y2:" & Replace(LastCell, "X", "Y")).FormulaLocal = "=СУММЕСЛИ(ДКУ!D:D;C2;ДКУ!G:G)"
End If
'Application.CutCopyMode = False
Workbooks(arr_crm_forma(i, 1)).Close False
Next i '------------------------------------------------------------------------
'открываем предудущий отчет по заявкам и добавляем в него данные -------------------------------------------------
Workbooks.Open str_month_folder & "\" & str_prev_order_report
ActiveWorkbook.SaveAs str_Cur_Order_report_Path
ActiveWorkbook.Sheets("Отчет").Cells(1, 1) = obj_Main.Range("B9") 'отчетный день
ActiveWorkbook.Sheets("Отчет").Cells(3, 1) = obj_Main.Range("E16") 'прошло рабочих дней
ActiveWorkbook.Sheets("Отчет").Cells(2, 1) = obj_Main.Range("E17") 'рабочих дней в отчетном месяце
obj_Forma_00.Sheets("Счет ДЛ").Cells.Copy
Workbooks(str_Cur_Order_report).Sheets("ДЛ").Cells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
obj_Forma_00.Sheets("Счет ЛС").Cells.Copy
Workbooks(str_Cur_Order_report).Sheets("ЛС").Cells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False ' очищаем буфер данных, чтобы ошибка не вылетала перед закрытием
obj_Forma_00.Sheets("Счет ДЛ").Activate
obj_Forma_00.Save
If obj_Main.Range("b12") = True Then obj_Forma_00.SaveAs str_voronka_folder & "\" & "Форма.xlsx"
DoEvents
obj_Forma_00.Close
repday = obj_Main.Range("E11")
ReportLastRow = Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Activate
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells.Range(Cells(4, 5 + repday), Cells(ReportLastRow, 5 + repday)).Copy
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells(4, 5 + repday).PasteSpecial Paste:=xlPasteValues
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells.Range(Cells(4, 44 + repday), Cells(ReportLastRow, 44 + repday)).Copy
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells(4, 44 + repday).PasteSpecial Paste:=xlPasteValues
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells.Range(Cells(4, 88 + repday), Cells(ReportLastRow, 88 + repday)).Copy
Workbooks(str_Cur_Order_report).Worksheets("Отчет").Cells(4, 88 + repday).PasteSpecial Paste:=xlPasteValues
'копируем данные на вкладку "прошлый"
str_prev_month_order_report_path = obj_Main.Range("D36")
Workbooks.Open str_prev_month_order_report_path
ActiveWorkbook.Sheets("Отчет").Cells.Copy
Workbooks(str_Cur_Order_report).Sheets("Прошлый").Cells.PasteSpecial
Application.CutCopyMode = False
Workbooks(Dir(str_prev_month_order_report_path)).Close 'закрываем открытую книгу прошлого месяца
'сохраняем отчет и сохраняем как отчет для отправки
Application.CutCopyMode = False ' очищаем буфер данных, чтобы ошибка не вылетала перед закрытием
Workbooks(str_Cur_Order_report).Sheets("Отчет").Activate
Workbooks(str_Cur_Order_report).Save
Workbooks(str_Cur_Order_report).Sheets("Отчет").Cells.Copy
Workbooks(str_Cur_Order_report).Sheets("Отчет").Cells.PasteSpecial Paste:=xlPasteValues
Workbooks(str_Cur_Order_report).Sheets("Динамика").Cells.Copy
Workbooks(str_Cur_Order_report).Sheets("Динамика").Cells.PasteSpecial Paste:=xlPasteValues
Workbooks(str_Cur_Order_report).Sheets("Сравнение").Cells.Copy
Workbooks(str_Cur_Order_report).Sheets("Сравнение").Cells.PasteSpecial Paste:=xlPasteValues
'со следующего месяца удалить следующую строку!!!
'Workbooks(str_Cur_Order_report).Sheets(Array("Динамика")).Delete
Workbooks(str_Cur_Order_report).Sheets(Array("ЛС", "ДЛ", "прошлый")).Delete
Workbooks(str_Cur_Order_report).Sheets("Отчет").Activate
ActiveWindow.ScrollColumn = 1
Workbooks(str_Cur_Order_report).SaveAs str_FileFor_Letter_report_Path 'сохраняем письмо для отправки
'заворачиваем выгрузки в папку
For i = 1 To filescount
If Not fso.FolderExists(str_day_crm_data_folder & "\" & obj_Main.Range("B9")) Then
fso.CreateFolder str_day_crm_data_folder & "\" & obj_Main.Range("B9")
End If
new_name = Replace(arr_crm_forma(i, 2), "Выгрузки дня", "Выгрузки дня\" & obj_Main.Range("B9"))
If fso.FileExists(new_name) Then Kill new_name
Name arr_crm_forma(i, 2) As new_name
Next
'закончили перемещение
'считаем последний день месяца, если он не был рабочим (в него как правило всё равно работают и на него должен быть отчет априори)
If obj_Main.Range("D39") Then
Workbooks(str_FileFor_Letter_report).Close
obj_Main.Range("A9").Value = obj_Main.Range("A9").Value + 1 ' вдруг там 2 дня было (30 и 31 в сб и вс, мало ли)
GoTo RunOneMoreTime
End If
'Готовим письмо
str_Letter_text = "Письмо.xlsx"
If IsBookOpen(str_Letter_text) = False Then Workbooks.Open ThisWorkbook.path & "\" & str_Letter_text
Workbooks(str_FileFor_Letter_report).Worksheets("Отчет").Cells.Copy
Workbooks(str_Letter_text).Worksheets("Данные").Cells.PasteSpecial
Workbooks(str_Letter_text).Worksheets("Письмо").Activate
If obj_Main.Range("b11") = True Then Workbooks(str_Letter_text).Save
Workbooks(str_FileFor_Letter_report).Close
'письмо приготовлено
Application.Wait 100
Call отправить_отчет_по_заявкам
If obj_Main.Range("b13") = True Then
Shell "explorer " & str_month_folder, vbNormalFocus 'открыть рабочую папку месяца
End If
Set obj_Forma_00 = Nothing
Set fso = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If obj_Main.Range("P12") = False Then 'запускаем ли сразу нарезку воронки
MsgBox "Execution Time: " & Format(Fix(Timer - T) / 86400, "h:mm:ss") & Format(Timer - T - Fix(Timer - T), ".00000")
Else
Call сформировать
End If
Set obj_Main = Nothing
End Sub
'создаем письмо для отправки
Sub отправить_отчет_по_заявкам()
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
Dim lr As Long, lLastR As Long
Dim str_Letter_text$, str_FileFor_Letter_report_Path As String
Dim d_delivery As Date
str_FileFor_Letter_report_Path = ThisWorkbook.Sheets("Main").Range("D33") 'тут путь файла для отправки
d_delivery = CDate(ThisWorkbook.Sheets("Main").Range("J15"))
str_Letter_text = "Письмо.xlsx"
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
'произошла ошибка создания объекта - выход
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
objOutlookApp.session.Logon
' Set sh1 = ThisWorkbook.ActiveSheet ' это у нас лист Список, где мэчатся подразделения, регионы и КОМУ, собственно отправка
' h = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' последнюю строку ищем
' If h < 6 Then MsgBox ("что-то не так с количеством строк")
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(str_FileFor_Letter_report_Path) = False Then MsgBox ("Отсутствует файл по пути: " & vbLf & str_FileFor_Letter_report_Path): Exit Sub
If IsBookOpen(ThisWorkbook.path & "\" & str_Letter_text) = False Then Workbooks.Open ThisWorkbook.path & "\" & str_Letter_text
'создаем новое сообщение
Set objMail = objOutlookApp.CreateItem(0)
'создаем сообщение
With objMail
.To = Workbooks(str_Letter_text).Sheets("Письмо").Cells(23, 2).Value 'адрес получателя
' .CC = Cells(i, 7).Value 'адрес для копии
.Subject = Workbooks(str_Letter_text).Sheets("Письмо").Range("B22")
.HTMLBody = Workbooks(str_Letter_text).Sheets("Письмо").Range("V22") ' & "<br><br>" & Signature 'тема сообщения
' .Subject = sh1.Cells(1, 11) 'текст сообщения
.Attachments.Add str_FileFor_Letter_report_Path
.deferredDeliveryTime = d_delivery 'время отправки
' .display
End With
If ThisWorkbook.Sheets("Main").Range("P2") = ".display" Then objMail.display
If ThisWorkbook.Sheets("Main").Range("P2") = ".send" Then objMail.send
' Next i
Workbooks(str_Letter_text).Close False
Set objOutlookApp = Nothing: Set objMail = Nothing: Set fso = Nothing
Application.ScreenUpdating = True
End Sub
Function GetBoiler(ByVal sFile As String) As String
'
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
Function IsBookOpen(wbName As String) As Boolean
Dim wbBook As Workbook
For Each wbBook In Workbooks
If wbBook.Name <> ThisWorkbook.Name Then
If Windows(wbBook.Name).Visible Then
If wbBook.Name = wbName Then IsBookOpen = True: Exit For
End If
End If
Next wbBook
End Function
Sub onBookOpen()
'если сегодня рабочий день и меньше 9:00 то запускаем + если с моего компа ( а то до 9 кто-нибудь откроет)
If autorunconditions Then
Call Макрос_Отчета_по_заявкам
' ThisWorkbook.Sheets("main").Range("A1").Value = Now
End If
If ThisWorkbook.Sheets("main").Range("G9").Value <> "р.д." Then
Application.Wait (Now + TimeValue("0:00:20"))
If Workbooks.Count > 1 Then
ThisWorkbook.Close True
Else
ThisWorkbook.Save
Application.Quit ' ActiveWorkbook.Close True
End If
End If
End Sub
Function autorunconditions() As Boolean
'условия запуска макросов на открытии и закрытии
autorunconditions = False
If ThisWorkbook.Sheets("main").Range("G9").Value = "р.д." _
And Time < CDate("8:10") _
And Environ("username") = "fpotokin" Then
autorunconditions = True
End If
End Function
Public Function ЕСЛИРАБДЕНЬ(ByRef день As Double, ByRef праздники As Range, ByRef рабочие_выходные As Range) As Byte
'определяет рабочий ли день - 1 или нет - 0
Application.MacroOptions Macro:="ЕСЛИРАБДЕНЬ", Description:="ddddd", Category:=14
v_search_result = Application.Match(день, рабочие_выходные, 0)
If Not IsError(v_search_result) Then ЕСЛИРАБДЕНЬ = 1: Exit Function
v_search_result = Application.Match(день, праздники, 0)
If Not IsError(v_search_result) Then ЕСЛИРАБДЕНЬ = 0: Exit Function
If Weekday(день, vbMonday) < 6 Then ЕСЛИРАБДЕНЬ = 1: Exit Function
End Function
Public Function РАБДЕНЬСРАБВЫХ(ByRef день As Double, ByVal число_дней%, ByRef праздники As Range, ByRef рабочие_выходные As Range) As Double
'определяет рабочий отстоящий на указанное кол-во раб.дней
Dim i%, n% 'n - кол-во рабочих ней с начальной даты
If число_дней > 0 Then
Do While n <> число_дней
i = i + 1
If ЕСЛИРАБДЕНЬ(день + i, праздники, рабочие_выходные) Then n = n + 1
Loop
РАБДЕНЬСРАБВЫХ = день + i
ElseIf число_дней < 0 Then
Do While n <> число_дней
i = i - 1
If ЕСЛИРАБДЕНЬ(день + i, праздники, рабочие_выходные) Then n = n - 1
Loop
РАБДЕНЬСРАБВЫХ = день + i
Else
РАБДЕНЬСРАБВЫХ = ЕСЛИРАБДЕНЬ(день, праздники, рабочие_выходные)
End If
End Function
Sub button99()
'Call Accelerator_Sub(True)
sample = "N'WBAXC21050D123587'"
query1 = ThisWorkbook.Sheets("numbers").Range("F2")
rowscount = ThisWorkbook.Sheets("numbers").Cells(Rows.Count, 1).End(xlUp).Row
If rowscount = 1 Then
dls = "N'" & ThisWorkbook.Sheets("numbers").Cells(1, 1) & "'"
Else
For i = 1 To rowscount
dls = dls & "N'" & ThisWorkbook.Sheets("numbers").Cells(i, 1) & "', "
Next
dls = Left(dls, Len(dls) - 2)
End If
query1 = Replace(query1, sample, dls)
Set qtku = ThisWorkbook.Sheets("result").QueryTables("Query from Microsoft CRM")
qtku.CommandText = query1
qtku.BackgroundQuery = False
qtku.Refresh
Set qtku = Nothing
'Call Accelerator_Sub(False)
End Sub
Sub Макрос1()
'
' Макрос1 Макрос
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://internal.carcade.com/static/html/addressbook/index.html", _
Destination:=Range("1"))
.CommandType = 0
.Name = "index"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
Sub find_in_array()
a = Sheets(1).[B2:B22]
b = Application.Match(40, a, 0) 'ищет в массиве (если массив с 1)
с = WorksheetFunction.Match(40, a, 0) 'ищет в массиве (если массив с 1)
bc = [diapazon10].Value
End Sub