ГлавнаяРазноеСкрипты для excel

VBA макрос для рассылки писем из Excel через Outlook. Скрипты для excel


Полезный скрипт для ведения журнала в Excel

Я веду свой журнал в Excel. Но есть одно неудобство. Сделки в QUIK представлены в виде списка транзакций, а не сделок как таковых с открытием и закрытием позиции. 

В журнале же нужно записывать сделку целиком с транзакцией на открытие и закрытие, чтобы видеть прибыль и убыток с каждой сделки.

Чтобы вручную не копировать строки в журнал, я написал две маленькие функции, которые выполняют одну простенькую задачу — они копируют сделку на закрытие и ставят ее рядом со сделкой на открытие. Конечно, перед этим нужно в Excel немного почистить данные, чтобы сделки были целиком (а не кусками по 1-2 лота) и по одному инструменту. 

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

Итак, вот что было:

Стало:

Код на VBA:

' Склеивает сделки Sub mergeDeals() ' Объявление переменных Dim LastRow, prevRow As Long Dim i As Long, j As Long Dim myRange As String ' Выделяем Лист, с которым работаем Sheets("Лист1").Select ' Определяем число заполненных строк With Worksheets("Лист1") LastRow = .Cells(.rows.Count, "A").End(xlUp).Row End With ' Проходимся по всем строкам от 1 до последней For i = 1 To LastRow With Worksheets("Лист1") ' Если строка четная, то копируем ее и вставляем рядом с предыдущей строкой If i Mod 2 = 0 Then prevRow = i - 1 myRange = "A" & i & ":" & "G" & i .Range(myRange).Copy Destination:=Worksheets("Лист1").Range("H" & prevRow) ' Удаляем содержимое скопированной строки .rows(i).ClearContents End If End With Next i End Sub ' Удаляет пустые строки Sub clearEmptyRows() ' Объявление переменных Dim r As Range, rows As Long, i As Long ' Объявление диапазона, в котором ищем пустые строки Set r = ActiveSheet.Range("A1:Z500") ' Удаление пустых строк rows = r.rows.Count For i = rows To 1 Step (-1) If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete Next End Sub

smart-lab.ru

Скрипт для экспресс-восстановления Excel-файлов после повреждения / Хабр

Данная заметка предназначен тем, у кого при попытке открыть Excel-файл выдается сообщение об ошибке вида: В моем случае с такой ошибкой открывался xlsx-файл (далее 1.xlsx), восстановленный с помощью R-Saver после вирусной атаки, подобной «Petya». После распаковки содержимого файла 1.xlsx в папку "\1" через контекстное меню были выданы следующие ошибки: Оказалось, что эти служебные файлы имеют нулевой размер. Я проделал аналогичную процедуру с исправным файлом 2.xlsx и скопировал из его папки "\2" ненулевые файлы [Content_Types].xml и .rels поверх пустых из "\1". Далее добавил содержимое папки "\1" в архив .zip и переименовал его в 3.xlsx. В результате, файл 3.xlsx уже открылся с корректными данными хотя и с предупреждением: Для автоматизации проделанных выше процедур был разработан скрипт vbscript, распространяемый «As Is».Исходный код скрипта ST1_XLSX_FIXER_v1option explicit Const THIS_SCRIPT_NAME = "ST1_XLSX_FIXER_v1.vbs" Const SUBDIR_XLS_SRC = "ST1_XLSX_FIXER_DATA_v1" Const SUBDIR_OUT = "ST1_XLSX_FIXED" Const RES_SUFFIX = "_fixed_ST1_v1" Dim fso: Set fso = CreateObject("Scripting.FileSystemObject") 'если запускаем скрипт автономно if WScript.ScriptName = THIS_SCRIPT_NAME then if WScript.Arguments.Count > 0 then Dim fname for each fname in WScript.Arguments if fso.GetExtensionName(fname) = "xls" then WScript.Echo "Файлы формата Excel 2003 и ранее (.xls) не поддерживаются" else FixCorruptedExcel fname end if next else WScript.Echo "Для работы перенесите выбранные xlsx-файлы на скрипт" end if end if Set fso = Nothing Sub FixCorruptedExcel(fpath) Dim out_dir: out_dir = fso.GetParentFolderName(fpath) & "\" & SUBDIR_OUT if Trim(out_dir) <> "" then 'создание папки результатов If not fso.FolderExists(out_dir) Then fso.CreateFolder(out_dir) end if End If 'cоздать копию xlsx-файла с расширением .zip Dim extract_dir: extract_dir = out_dir & "\" & fso.GetBaseName(fpath) Dim fpath_zip: fpath_zip = extract_dir & ".zip" fso.CopyFile fpath, fpath_zip 'выходной файл Dim fpath_fixed: fpath_fixed = extract_dir & RES_SUFFIX & ".xlsx" if fso.FileExists(fpath_fixed) then fso.DeleteFile fpath_fixed 'распаковка zip UnzipFile fpath_zip, extract_dir 'удаление zip-файла fso.DeleteFile fpath_zip 'восстановление битых файлов из папки Dim script_path: script_path = fso.GetParentFolderName(Wscript.ScriptFullName) fso.CopyFolder script_path & "\" & SUBDIR_XLS_SRC, extract_dir 'создание zip CreateEmptyZipFile fpath_zip 'архивирование extract_dir Dim shell: set shell = CreateObject("Shell.Application") Dim extract_dir_obj: set extract_dir_obj = fso.GetFolder(extract_dir) shell.NameSpace(fpath_zip).CopyHere shell.NameSpace(extract_dir).Items do until shell.namespace(fpath_zip).items.count = shell.namespace(extract_dir).items.count wscript.sleep 1000 loop 'zip -> xlsx fso.MoveFile fpath_zip, fpath_fixed 'удаление unzip-папки fso.DeleteFolder extract_dir, true WScript.Echo "Исправленный файл: " & vbCrLf & fpath_fixed Set shell = Nothing end sub sub UnzipFile(fpath_zip, extract_dir) 'создание папки для распаковки If not fso.FolderExists(extract_dir) Then fso.CreateFolder(extract_dir) End If 'извлечение xlsx - аналог операции контекстного меню "Распаковать в ..." Dim shell: set shell = CreateObject("Shell.Application") Dim sub_files: set sub_files = shell.NameSpace(fpath_zip).items Const FOF_SILENT = &h5& Const FOF_RENAMEONCOLLISION = &H8& Const FOF_NOCONFIRMATION = &h20& Const FOF_ALLOWUNDO = &h50& Const FOF_FILESONLY = &H80& Const FOF_SIMPLEPROGRESS = &h200& Const FOF_NOCONFIRMMKDIR = &h300& Const FOF_NOERRORUI = &h500& Const FOF_NOCOPYSECURITYATTRIBS = &H800& Const FOF_NORECURSION = &h2000& Const FOF_NO_CONNECTED_ELEMENTS = &h3000& Dim args: args = FOF_SILENT + FOF_NOCONFIRMATION + FOF_NOERRORUI shell.NameSpace(extract_dir).CopyHere sub_files, args Set shell = Nothing end sub sub CreateEmptyZipFile(fname) if fso.FileExists(fname) then WScript.Echo "Файл " & fname & " уже существует", vbCritical, WScript.ScriptFullName end if Const ForWriting = 2 Dim fp: set fp = fso.OpenTextFile(fname, ForWriting, True) fp.Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0)) fp.Close end sub Дополнительно к скрипту в архиве прилагается папка ST1_XLSX_FIXER_DATA_v1, где лежат эталонные файлы для замещения. Можно изменять ее содержимое в целях расширения области применимости скрипта на другие варианты битых файлов. Например, добавить туда обнаруженные вами варианты нулевых файлов.

Для работы скрипта необходимо:

  1. Скачать и распаковать архив ST1_XSLX_FIXER_v1.zip в любую папку
  2. Левой кнопкой мыши перенести один или несколько xlsx-файлов на скрипт ST1_XLSX_FIXER_v1.vbs
  3. Начнется процесс обработки каждого файла:
  4. После успешной обработки каждого файла выдается сообщение вида:
Принцип работы скрипта:
  1. Сохраняет входной файл неизменным
  2. Создает подпапку ST1_XLSX_FIXED
  3. Создает в ST1_XLSX_FIXED переименованную в zip копию xlsx
  4. Распаковывает zip в папку и копирует поверх нее ST1_XLSX_FIXER_DATA_v1
  5. Архивирует полученную папку в zip и переименовывает полученный файл в xlsx
Заключение

Данные эксперимент не претендует на общность использования, используйте предлагаемое решение на свой страх и риск. Со своей стороны планирую провести более широкий эксперимент и по результатам доработать скрипт. Текущее явное ограничение — скрипт не анализирует размер замещаемых файлов при копировании из ST1_XLSX_FIXER_DATA_v1, поэтому не умеет определять, какие именно служебные файлы оказались пустыми и требуют своей замены. Скорее всего, подобный способ применим, если утеряны именно служебные файлы, а не рабочие листы из "\1\xl\worksheets".

Также скрипт не подходит для файлов с расширением xls, созданных в версиях Excel 2003 и ранее, поскольку там используется другой формат хранения данных.

habr.com

Скрипт MS Excel для анализа клиентской базы

В прошлом посте «Как посчитать коэффициент удержания клиентов«, я предлагал принять участие в тестирование. Выгрузку из 1С надо было направить мне на почту. Ну что ж, спасибо тем, кто рискнул это сделать. Благодаря им я смог обкатать скрипт и понять, как адаптировать к различиям в отчетах. Скачать скрипт можно совершенно бесплатно, воспользовавшись формой ниже.

[email-download download_id=»665″ contact_form_id=»669»]

Скрипт умеет:

  • определять является ли клиент активным или ушел
  • выявлять клиентов из группы риска. А значит надо что срочно звонить или встречаться
  • считать коэффициенты удержания по годам и кварталам

Как настроить скрипт и пользоваться им ниже.

Для настройки вам необходимо скопировать на «Лист1» отчет из 1С, в котором содержаться группировки по клиентам и отгрузкам за некий период (лучше больше трех лет). Перед копированием лучше очистить «Лист1» при помощи кнопки на листе «Управление».

Запомните номер столбца и строки, как показано на рисунке выше. И укажите из в соответствующих ячейках на листе «Управление». Так же надо указать период для расчета и дни между заказами (среднее значение) для использования по умолчанию.

Далее, последовательно нажать кнопки «Преобразовать базу» и «Рассчитать показатели удержания» на листе «Управления». После 2-8 минут расчетов, наслаждайтесь результатами.

Если у Вас появятся вопросы — обращайтесь! Буду рад дать пояснения или адаптировать скрипт под ваш формат.

 

kulinich.ru

VBA макрос для рассылки писем из Excel через Outlook

Возникла задача организации рассылки писем по списку email пользователей в Excel. Причем в каждом письме нужно указывать некоторые данные, индивидуальные для каждого пользователя. Я попытался реализовать этот функционал с помощью vba макроса в Excel, который отправляет почту через настроенный на компьютере почтовый профиль Outlook. Ниже мое решение.

Допустим, у нас есть Excel файл, содержащий следующие столбцы:

Email пользователя | ФИО | Время последней смены пароля | Статус учетной записи

В рамках моей задачи нужно каждому пользователю из списка отправить письмо вида:

Тема: Статус учетной записи в домене winitpro.ruТело письма: Уважаемый %FullUsername%Ваша учетная запись в домене winitpro.ru — %status%Время последней смены пароля: %pwdchange%

Создадим новый макрос: вкладка Вид -> Макросы. Укажите имя макроса send_email и нажмите кнопку Создать:

В открывшемся редакторе VBA вставьте следующий код (я снабдил его всеми необходимыми комментариями). Для автоматизации отправки писем я воспользуюсь функцией CreateObject(«Outlook.Application»), позволяющей создать и использовать в скрипте объект приложения Outlook.

Важно. На компьютере, рассылающем письма должен быть установлен и настроен почтовый профиль Outlook. Именно с этого ящика  (и адреса) будет выполнятся рассылка.

Sub send_email()Dim olApp As ObjectDim olMailItm As ObjectDim iCounter As IntegerDim Dest As VariantDim SDest As String' тема письмаstrSubj = "Статус учетной записи в домене winitpro.ru"On Error GoTo dbg' создаем новый объект типа OutlookSet olApp = CreateObject("Outlook.Application")For iCounter = 1 To WorksheetFunction.CountA(Columns(1))' создаем новый элемент (письмо) в OutlookSet olMailItm = olApp.CreateItem(0)strBody = ""useremail = Cells(iCounter, 1).ValueFullUsername = Cells(iCounter, 2).ValueStatus = Cells(iCounter, 4).Valuepwdchange = Cells(iCounter, 3).Value'формируем тело письмаstrBody = "Уважаемый " & FullUsername & vbCrLfstrBody = strBody & "Ваша учетная запись в домене winitpro.ru " & Status & vbCrLfstrBody = strBody & "Время последней смены пароля: " & pwdchange & vbCrLfolMailItm.To = useremailolMailItm.Subject = strSubjolMailItm.BodyFormat = 1' 1 - текстовый формат письма, 2 -  HTML форматolMailItm.Body = strBodyolMailItm.Send'следующую строку можно использовать для отладки текста письма, закомментировав предыдущую'MsgBox strBodySet olMailItm = NothingNext iCounterSet olApp = Nothingdbg:'отображение ошибок, если естьIf Err.Description <> "" Then MsgBox Err.DescriptionEnd Sub

Данный Excel файл нужно сохранить с расширением xlsm (формат книги Excel с поддержкой макросов). Для запуска рассылки выберите созданную процедуру (макрос) и нажмите кнопку выполнить.

Макрос последовательно переберет все строки на листе Excel, сформирует и отправит по одному письму на каждый Email из списка.

winitpro.ru