Трюки Excel. Скрипты excel

Excel - работаем с макросами

В процессе работы неоднократно приходиться сталкиваться с табличными процессорами типа Excel. И хотя это не совсем САПР, но информацию в рамках BIM контекста хочешь не хочешь, а приходится обрабатывать, либо с помощью Базы Данных, либо в тех самых экселевских табличках. А лучше и так и эдак.

Естественно, как и во всем, что связанно с компьютером эту деятельность тоже можно изрядно упростить с помощью автоматизации. С появлением таких вещей как Pivot Tables и Power Queries — так и вовсе становится не понятно как работали с информацией до этого. Но тут мы поговорим о старых добрых ламповых макросах на VBA.

Excel VBA Macro script

Макросы в экселе пишут на VBA (Visual Basic Advance) — слегка переработанный под нужды офисного пакета старый добрый Бейсик, со всеми своими достоинствами и недостатоками. Сами программы по умолчанию являются частью эксель файла. И убедится в этом можно с помощью соответствующей консоли (Microsoft Visual Basic for Application)

Добраться до них можно в любое время нажав сочетание клавишь Alt+F11

Но сначала надо включить вкладку Developers в стандартной ленте экселя.

Для этого:

Ннаводим курсор на ленту и нажимаем Правую Клавишу Мыши (ПКМ)
В открывшемся списке выбираем — Customize the Ribbon (Настройка Ленты)
Ищем как показано на скриншоте пункт Developer (Разработка) и нажимаем чтобы появилась галочка
Ок.

Путем этих не хитрых манипуляций мы получили доступ к панели разработчика в Excel — не будем особо заострять на ней внимание. Нам там понадобится буквально несколько кнопок

— Visual Basic — собственно уже обусжденная выше консоль для работы со скриптами.

— Macos — список доступных макросов для использования.

— Record Macro — эта кнопка позволяет включить запись ваших действий с табличным редактором.

Ну и дальше порядок работы довольно простой — запускаете запись макроса, производите необходимые манипуляции с данными, останавливаете запись (той же кнопкой что и включили), идете в редактор, правите если необходимо. Потом с помощью списка макросов вызываете вновь созданный макрос в любое удобное время.

Однако есть нюанс. Созданный макроскрипт будет по умолчанию доступен только в одном эксель файле. Скопировать его в другой — конечно можно, но довольно заморочно. Есть ли выход из этой ситуации? Конечно!

Создаем собственную библиотеку Excel макросов — Personal.xlsb

Для этого нам нужно создать файл Personal.xlsb. Создается он один раз, и потом автоматически подгружается Экселем, благодаря чему сохраненные в нем Скрипты и функции становятся доступны во всех ваших файлах. Другой плюс — теперь они не сохраняются в самих файлах, и соответственно можно без опаски передавать результаты за пределы компании.

Собственно смотрим на картинку:

1. Необходимо включить макрос на запись.

2. В появившемся окне в выпадающем списке выбрать пункт — Personal Macro Workbook. Если такого файла не существует — он будет создан автоматические (то что нам и нужно)

3. Запускаем скрипт на запись

4. И останавливаем её.

Готово. Теперь у нас есть файл в который наши модули и функции можно закинуть единожды, а доступны они будут сразу во всех эксель файлах. К тому же так они не утекут за пределы компании, вместе с файлами.

cadsupport.ru

скрипты

Задача переноса графиков, диаграмм, таблиц из Excel в презентацию PowerPoint осложняется тем, что в последних версиях редактора презентаций (2007, 2010) разработчики убрали возможность записи производимых действий в макрос. Поэтому, для настройки внешнего вида презентации под собственные условия, нужно перерыть документацию по VBA для PowerPoint, либо просмотреть множество специализированных форумов. Ниже приведен код примера создания презентации из диаграмм Excel.

Private Sub export_to_pp() Set pr = CreateObject("PowerPoint.Application") Set mpr = pr.Presentations.Add 'Определение имени создаваемой презентации ppName = "Имя_для_презентации" 'Добавление пустого слайда Set ppSlide = mpr.Slides.Add(mpr.Slides.Count, ppLayoutBlank) 'Цвет фона слайда ppSlide.Master.Background.Fill.ForeColor.RGB = RGB(200, 200, 200) 'Добавление блока (Orientation, Left, Top, Width, Height) 'функция Application.CentimetersToPoints переводит сантиметры в пиксели Set TextShape = ppSlide.Shapes.AddTextbox(1, _ Application.CentimetersToPoints(1.09), _ Application.CentimetersToPoints(1.2), _ Application.CentimetersToPoints(22.86), _ Application.CentimetersToPoints(1.2)) TextShape.TextFrame.TextRange.Text = "Текст надписи" 'Настройка параметров блока с текстом TextShape.TextFrame.TextRange.Font.Name = "Calibri" TextShape.TextFrame.TextRange.Font.Size = 18 TextShape.TextFrame.TextRange.Font.Bold = True 'Отключение автоматического подгона размера блока под текст TextShape.TextFrame.AutoSize = 0 TextShape.Height = Application.CentimetersToPoints(1.2) TextShape.TextFrame.TextRange.Font.Color = vbWhite 'Вертикальное выравнивание текста по центру TextShape.TextFrame.VerticalAnchor = msoAnchorMiddle 'Копируем диаграмму в PowerPoint ListName.ChartObjects("ChartName").Copy Set chart1 = ppSlide.Shapes.PasteSpecial(ppPastePNG) chart1.Left = Application.CentimetersToPoints(1.52) chart1.Top = Application.CentimetersToPoints(3.65) 'Копируем таблицу как OLE object ListName.Range("H51:M60").Copy Set table1 = ppSlide.Shapes.PasteSpecial(ppPasteOLEObject) table1.Left = Application.CentimetersToPoints(1.52) table1.Top = Application.CentimetersToPoints(13.72) 'Копируем таблицу как рисунок ListName.Range("H61:M70").Copy Set table2 = ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile) table2.Left = Application.CentimetersToPoints(13.16) table2.Top = Application.CentimetersToPoints(13.72) Application.CutCopyMode = False 'Сохраняем презентацию в папке с текущей книгой Excel mpr.SaveAs (ThisWorkbook.Path + "\" + ppName) mpr.Close pr.Quit End Sub

Продолжить чтение »

opennotes.ru

Vbscript + Active Directory + Excel. Генерируем документ в Excel при помощи скрипта на vbscript.

Возникла необходимость вытянуть данные по пользователям из Active Directory (AD) в таблицу Excel в формате, понятном не только системному администратору :) . Т.к. пользователи приходят/увольняются, то вручную каждый раз переделывать таблицу размером в 2 листа формата А3 мелким шрифтом как-то не по админски, поэтому, будем автоматизировать процесс создания таблицы при помощи VBScript - предоставим серверу выполнение этой задачи, пока мы будем заниматься более полезными вещами.

2) Существует несколько филиалов территориально расположенных вдали друг от друга, каждый филиал сидит в своем OU и имеет свой набор групп пользователей. Все группы пользователей филиалов являются членами одной общей группы филиала. В свою очередь каждая общая группа филиала является членом общей группы предприятия.

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

Содержимое скрипта надо сохранить в виде обычного текстового файла (NOTEPAD) и изменить расширение на .vbsНапример:examle.vbs

Const ADS_SCOPE_SUBTREE = 2 Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D 'On Error Resume Next ' Не спотыкаться на ошибках

' Обьявляем массивы Dim XLAp Dim XLWb Dim XLWs Dim objADObject, strGroup, objGroupList

' Запускаем EXCEL Set XLAp = CreateObject("Excel.Application") XLAp.Visible = True lst = 1 Set XLWb = XLAp.Workbooks.Add Set XLWs = XLWb.Worksheets(lst) XLWs.Activate

' Настройки листа EXCEL XLAp.ActiveSheet.PageSetup.Zoom = 60 XLAp.ActiveSheet.PageSetup.PaperSize = 8 XLAp.ActiveSheet.PageSetup.CenterHorizontally = True XLAp.ActiveSheet.PageSetup.LeftMargin = XLAp.Application.InchesToPoints(0.25) XLAp.ActiveSheet.PageSetup.RightMargin = XLAp.Application.InchesToPoints(0.25) XLAp.ActiveSheet.PageSetup.TopMargin = XLAp.Application.InchesToPoints(0.75) XLAp.ActiveSheet.PageSetup.BottomMargin = XLAp.Application.InchesToPoints(0.75) XLAp.ActiveSheet.PageSetup.HeaderMargin = XLAp.Application.InchesToPoints(0.3) XLAp.ActiveSheet.PageSetup.FooterMargin = XLAp.Application.InchesToPoints(0.3)

' Выставляем длинну колонок XLAp.Columns("A:A").ColumnWidth = 0.58 XLAp.Columns("B:C").ColumnWidth = 2.71 XLAp.Columns("D:D").ColumnWidth = 21.86 XLAp.Columns("E:E").ColumnWidth = 29.43 XLAp.Columns("F:F").ColumnWidth = 4.43 XLAp.Columns("G:G").ColumnWidth = 36.86 XLAp.Columns("H:T").ColumnWidth = 5.00 XLAp.Columns("U:U").ColumnWidth = 42.14 XLAp.Columns("V:V").ColumnWidth = 2.43 ' Выставляем параметры столбцов XLAp.Range("D:D").Select XLAp.Selection.HorizontalAlignment = -4108 XLAp.Selection.VerticalAlignment = -4108 XLAp.Selection.Font.Bold = True XLAp.Selection.Font.Name = "Tahoma" XLAp.Selection.Font.Size = 8 XLAp.Range("H:T").Select XLAp.Selection.Font.Bold = True XLAp.Selection.Font.Name = "Tahoma" XLAp.Selection.Font.Size = 8 XLAp.Selection.HorizontalAlignment = -4108 XLAp.Selection.VerticalAlignment = -4108 ' Выставляем высоту ячеек XLAp.Rows("1:1").RowHeight = 5.25 XLAp.Rows("2:2").RowHeight = 12.75 XLAp.Rows("3:3").RowHeight = 18.75 XLAp.Rows("7:7").RowHeight = 15.75 XLAp.Rows("4:6").RowHeight = 12.75 XLAp.Rows("10:10").RowHeight = 132.75 ' Задаем шрифт и высоту строк ячеек XLAp.Rows("13:255").Select XLAp.Selection.Font.Name = "Tahoma" XLAp.Selection.Font.Size = 8 XLAp.Selection.RowHeight = 10.00 ' Обьединяем ячейки XLAp.Range("B7:V7").Merge XLAp.Range("B10:C10").Merge XLAp.Range("F9:F10").Merge XLAp.Range("B9:C10").Merge XLAp.Range("D9:D10").Merge XLAp.Range("E9:E10").Merge XLAp.Range("H9:K9").Merge XLAp.Range("L9:P9").Merge XLAp.Range("Q9:Q10").Merge XLAp.Range("R9:R10").Merge XLAp.Range("S9:S10").Merge XLAp.Range("T9:T10").Merge XLAp.Range("U9:V10").Merge

' Оформляем шапку таблицы XLAp.Range("U2:U6").Select With XLAp.Selection.Font .Name = "Tahoma" .Size = 10 End With XLAp.Range("U2:U2").Select XLAp.ActiveCell.FormulaR1C1 = "УТВЕРЖДАЮ" XLAp.Range("U3:U3").Select XLAp.ActiveCell.FormulaR1C1 = "__________________________________________" XLAp.Range("U4:U4").Select XLAp.ActiveCell.FormulaR1C1 = "__________________________________________" XLAp.Range("U5:U5").Select XLAp.ActiveCell.FormulaR1C1 = "__________________________________________" XLAp.Range("U6:U6").Select XLAp.ActiveCell.FormulaR1C1 = "__________________________________________" ' Красим, заполняем шапку таблицы XLAp.Range("B7:V7").Select With XLAp.Selection.Font .Bold = True .Name = "Calibri" .Size = 16 End With XLAp.Selection.HorizontalAlignment = -4108 XLAp.Selection.VerticalAlignment = -4108 XLAp.ActiveCell.FormulaR1C1 = "Схема распределения прав пользователей в группах домена DOMEN.LOCAL"

XLAp.Range("B9:V10").Select XLAp.Selection.HorizontalAlignment = -4108 XLAp.Selection.VerticalAlignment = -4108 With XLAp.Selection.Font .Bold = True .Name = "Tahoma" .Size = 8 End With With XLAp.Selection.Borders .LineStyle = 1 .Weight = -4138 End With With XLAp.Selection.Interior .ThemeColor = 1 .TintAndShade = -0.149998474074526 End With

XLAp.Range("B10:C10").Select XLAp.ActiveCell.FormulaR1C1 = "№"

XLAp.Range("D9:D10").Select XLAp.ActiveCell.FormulaR1C1 = "Название группы"

XLAp.Range("E9:E10").Select XLAp.Selection.Interior.Color = 14922893 XLAp.ActiveCell.FormulaR1C1 = "Название подгруппы (Англ.)"

XLAp.Range("F9:F10").Select XLAp.Selection.Orientation = -90 XLAp.Selection.Interior.Color = 14922893 XLAp.ActiveCell.FormulaR1C1 = " Основное место работы"

XLAp.Range("G9:G9").Select XLAp.Selection.Interior.Color = 14922893 XLAp.ActiveCell.FormulaR1C1 = "Название подгруппы (Рус.)"

XLAp.Range("G10:G10").Select XLAp.ActiveCell.FormulaR1C1 = "Название ресурса"

XLAp.Range("H9:K9").Select XLAp.Selection.Interior.Color = 10147522 XLAp.ActiveCell.FormulaR1C1 = "Project 2007"

XLAp.Range("L9:P9").Select XLAp.Selection.Interior.Color = 12106214 XLAp.ActiveCell.FormulaR1C1 = "Сервера"

XLAp.Range("h20:h20").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Руководитель организации"

XLAp.Range("I10:I10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Руководитель ресурсов"

XLAp.Range("J10:J10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Руководитель проектов"

XLAp.Range("K10:K10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Участник групп"

XLAp.Range("L10:L10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "1С_User"

XLAp.Range("M10:M10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Terminal_user"

XLAp.Range("N10:N10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "VPN Доступ"

XLAp.Range("O10:O10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Интернет"

XLAp.Range("P10:P10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Почтовый ящик"

XLAp.Range("Q9:Q10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Доступ к USB портам"

XLAp.Range("R9:R10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Доступ к CD-RW"

XLAp.Range("S9:S10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "Видеонаблюдение"

XLAp.Range("T9:T10").Select XLAp.Selection.Orientation = -90 XLAp.ActiveCell.FormulaR1C1 = "ПО `БАРЬЕР`"

XLAp.Range("U9:V10").Select XLAp.ActiveCell.FormulaR1C1 = "Примечание"'---------------------------------------------------------------------------------------

'Начинаем заполнять таблицу значениями из ADSet objGroup = GetObject("LDAP://CN=domen_all,OU=domen,DC=rdomen,DC=local")objGroup.GetInfoarrMemberOf = objGroup.GetEx("member")

' Перестановка значений массива arMem0 = arrMemberOf(0) arMem1 = arrMemberOf(1) arMem2 = arrMemberOf(2) arMem3 = arrMemberOf(3) arrMemberOf(0) = arMem3 arrMemberOf(1) = arMem0 arrMemberOf(2) = arMem1 arrMemberOf(3) = arMem2

x = 12 ' Номер строки для вывода razdel = 1 ' Счетчик раздела для нумерации разделов в таблице BorderMainX = x ' Счетчик для выделения рамкой общей группы предприятияFor Each strMember in arrMemberOf'Рисуем строку с названием основной группы красным цветом XLAp.Rows(x).RowHeight = 15.00 XLAp.Range("B"&x &":C"&x).Merge XLAp.Range("E"&x &":V"&x).Merge XLAp.Range("B"&x &":V"&x).Select XLAp.Selection.Font.Bold = True XLAp.Selection.Font.Name = "Tahoma" XLAp.Selection.Font.Size = 8 XLAp.Selection.HorizontalAlignment = -4108 XLAp.Selection.VerticalAlignment = -4108 XLAp.Selection.Borders.LineStyle = 1 XLAp.Selection.Borders.Weight = -4138 XLAp.Selection.Interior.Color = 4671487 'Обрезаем лишнее tmpv = instr(1,strMember,",") - 1 tmpv1 = left(strMember,tmpv) tmpv2 = right(tmpv1, len(tmpv1) - 3) DescGr = GetDescript(strMember) XLAp.Cells(x, 2).Value = razdel XLAp.Cells(x, 4).Value = tmpv2 XLAp.Cells(x, 5).Value = DescGr ' Следующий вложенный цикл Podrazdel1 = 1 ' Счетчик подраздела Set objGroup2 = GetObject("LDAP://" & strMember) objGroup2.GetInfo arrMemberOf2 = objGroup2.GetEx("member") Call quickSort( arrMemberOf2, 0, UBound( arrMemberOf2 )) For Each strMember2 in arrMemberOf2 x = x + 2 tmpv = instr(1,strMember2,",") - 1 tmpv1 = left(strMember2,tmpv) tmpv2 = right(tmpv1, len(tmpv1) - 3) ' Рисуем желтую ячейку XLAp.Range("C"&x &":D"&x).Select XLAp.Selection.NumberFormat = "@" XLAp.Selection.Font.Bold = True XLAp.Selection.HorizontalAlignment = -4108 XLAp.Selection.Borders.LineStyle = 1 XLAp.Selection.Borders.Weight = -4138 XLAp.Selection.Interior.Color = 65535 XLAp.Cells(x, 3).Value = razdel &"." &Podrazdel1 XLAp.Cells(x, 4).Value = tmpv2 ' Начинаем следующий вложенный цикл BorderPrazdelX = x +1 ' Записываем начальную координату х для рамки раздела Podrazdel2 = 1 ' Счетчик подраздела Set objGroup3 = GetObject("LDAP://" & strMember2) objGroup3.GetInfo arrMemberOf3 = objGroup3.GetEx("member") Call quickSort( arrMemberOf3, 0, UBound( arrMemberOf3 )) 'Сортировка For Each strMember3 in arrMemberOf3 x = x + 1 tmpv = instr(1,strMember3,",") - 1 tmpv1 = left(strMember3,tmpv) tmpv2 = right(tmpv1, len(tmpv1) - 3) 'Рисуем голубую ячейку XLAp.Range("D"&x &":U"&x).Select XLAp.Selection.NumberFormat = "@" XLAp.Selection.Font.Bold = True XLAp.Selection.Borders.LineStyle = 1 XLAp.Selection.Borders.Weight = -4138 XLAp.Selection.Interior.Color = 14922893 XLAp.Cells(x, 4).Value = razdel &"." &Podrazdel1 &"." &Podrazdel2 XLAp.Cells(x, 5).Value = tmpv2 DescGr3 = GetDescript(strMember3) XLAp.Cells(x, 7).Value = DescGr3 DescGr3 = "" 'ProjectOrgDir проверка ----------------------------------- strGp = "ProjectOrgDir" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 8).Value = "V" End If 'ProjectResManager проверка ----------------------------- strGp = "ProjectResManager" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 9).Value = "V" End If 'ProjectManProect проверка ------------------------------ strGp = "ProjectManProect" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 10).Value = "V" End If 'ProjectUsers проверка ----------------------------------- strGp = "ProjectUsers" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 11).Value = "V" End If '1C_user проверка ----------------------------------- strGp = "1C_user" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 12).Value = "V" End If 'Terminal_user проверка------------------------------ strGp = "Terminal_user" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 13).Value = "V" End If 'Inet_User проверка --------------------------------- strGp = "internet_user" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 15).Value = "V" End If

' Начинаем следующий вложенный цикл, который выводит пользователей Set objGroup4 = GetObject("LDAP://" & strMember3) objGroup4.GetInfo On Error Resume Next 'If Not (IsNull(objGroup4.GetInfo)) then arrMemberOf4 = objGroup4.GetEx("member") If Err.Number <> E_ADS_PROPERTY_NOT_FOUND Then

'XLAp.Cells(x, 25).Value = arrMemberOf4(0) Call quickSort( arrMemberOf4, 0, UBound( arrMemberOf4 )) ' Сортировка For Each strMember4 in arrMemberOf4 x = x + 1 tmpv = instr(1,strMember4,",") - 1 tmpv1 = left(strMember4,tmpv) tmpv2 = right(tmpv1, len(tmpv1) - 3) XLAp.Range("F"&x &":U"&x).Select XLAp.Selection.Borders.LineStyle = 1 XLAp.Range("F"&x &":G"&x).Select If DisabledAkk(strMember4) Then 'Выделяем красным отключенных пользователей XLAp.Selection.Interior.Color = 4671487 End If UsEmail = GetEmail(strMember4) XLAp.Cells(x, 21).Value = UsEmail UsEmail = "" XLAp.Cells(x, 7).Value = tmpv2 'ProjectOrgDir проверка ---------------------------- strGp = "ProjectOrgDir" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 8).Value = "V" End If 'ProjectResManager проверка ---------------------- strGp = "ProjectResManager" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 9).Value = "V" End If 'ProjectManProect проверка ------------------------ strGp = "ProjectManProect" Set objADus = GetObject("LDAP://" & strMember3) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 10).Value = "V" End If 'ProjectUsers проверка ----------------------------- strGp = "ProjectUsers" Set objADus = GetObject("LDAP://" & strMember4) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 11).Value = "V" End If '1C_user проверка ---------------------------------- strGp = "1C_user" Set objADus = GetObject("LDAP://" & strMember4) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 12).Value = "V" End If 'Terminal_user проверка ---------------------------- strGp = "Terminal_user" Set objADus = GetObject("LDAP://" & strMember4) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 13).Value = "V" End If 'VPN_user проверка -------------------------------- strGp = "VPN_user" Set objADus = GetObject("LDAP://" & strMember4) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 14).Value = "V" End If 'Inet_User проверка -------------------------------- strGp = "internet_user" Set objADus = GetObject("LDAP://" & strMember4) If (IsMember(objADus, strGp) = True) Then XLAp.Cells(x, 15).Value = "V" End If '---------------------------------------------------- XLAp.Range("H"&x &":K"&x).Select XLAp.Selection.Interior.Color = 10147522 XLAp.Range("L"&x &":P"&x).Select XLAp.Selection.Interior.Color = 12106214 Next arrMemberOf4 ="" ' сбрасываем в ноль для предотвращения повторений End If Podrazdel2 = Podrazdel2 + 1 ' Выделяем рамкой раздел XLAp.Range("D"&BorderPrazdelX &":U"&x).Select BigBorder XLAp.Range("E"&BorderPrazdelX &":E"&x).Select BigBorder XLAp.Range("G"&BorderPrazdelX &":G"&x).Select BigBorder XLAp.Range("F"&BorderPrazdelX &":F"&x).Select BigBorder XLAp.Range("H"&BorderPrazdelX &":K"&x).Select BigBorder XLAp.Range("L"&BorderPrazdelX &":P"&x).Select BigBorder XLAp.Range("Q"&BorderPrazdelX &":T"&x).Select BigBorder Next Podrazdel1 = Podrazdel1 + 1 Next

razdel = razdel + 1 XLAp.Range("B"&BorderMainX &":V"&x+1).Select 'Рисуем рамку главной группы BigBorder x = x + 3 ' Делаем отступ для следующей группы BorderMainX = xNext

Function BigBorder()' Функция выделения раздела рамкой XLAp.Selection.Borders(5).LineStyle = -4142 XLAp.Selection.Borders(6).LineStyle = -4142 With XLAp.Selection.Borders(7) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = -4138 End With With XLAp.Selection.Borders(8) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = -4138 End With With XLAp.Selection.Borders(9) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = -4138 End With With XLAp.Selection.Borders(10) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = -4138 End WithEnd Function

Function GetDescript(LdpAd)' Функция возврата текстового поля description группы Set oGroup = GetObject ("LDAP://" & LdpAd) GetDescript = oGroup.DescriptionEnd Function

Function GetEmail(LdpAd)' Функция возврата текстового поля группы On Error Resume Next Set oGroup = GetObject ("LDAP://" & LdpAd) GetEmail = oGroup.EmailAddress Err.ClearEnd Function

Function DisabledAkk(LdpAd)' Функция проверки отключен ли аккаунт Set oGroup = GetObject ("LDAP://" & LdpAd) DisabledAkk = oGroup.AccountDisabledEnd Function'--------------------------------------------------------------------------------Function splitArray(anArray, leftBound, rightBound) ' Сортировка массива Dim leftValue, rightValue, pivotValue, pivot, left, right left = leftBound pivot = left right = rightBound pivotValue = anArray( pivot )

Do while left < right rightValue = anArray( right ) Do while pivotValue <= rightValue and left < right right = right - 1 rightValue = anArray( right ) Loop anArray( left ) = rightValue

leftValue = anArray( left ) Do while pivotValue > leftValue and left < right left = left + 1 leftValue = anArray( left ) Loop anArray( right ) = leftValue Loop

anArray( left ) = pivotValue splitArray = left End function

' собственно сортировка Function quickSort(anArray, leftBound, rightBound) Dim splitIndex, left, right left = leftBound right = rightBound If ( left < right ) then splitIndex = splitArray( anArray, left, Right ) Call quickSort( anArray, left, splitIndex - 1 ) Call quickSort( anArray, splitIndex + 1, right ) End if End Function

'------------------------------------------------------------Function IsMember(ByVal objADObject, ByVal strGroup) ' Function to test for group membership. ' objADObject is a user or computer object. ' strGroup is the NT name (sAMAccountName) of the group to test. ' objGroupList is a dictionary object, with global scope. ' Returns True if the user or computer is a member of the group. ' Subroutine LoadGroups is called once for each different objADObject.

If (IsEmpty(objGroupList) = True) Then Set objGroupList = CreateObject("Scripting.Dictionary") objGroupList.CompareMode = vbTextCompare Call LoadGroups(objADObject) End If If (objGroupList.Exists(objADObject.sAMAccountName & "\") = False) Then Call LoadGroups(objADObject) End If IsMember = objGroupList.Exists(objADObject.sAMAccountName & "\" _ & strGroup)End Function

Sub LoadGroups(ByVal objADObject) ' Subroutine to populate dictionary object with group memberships. ' objGroupList is a dictionary object, with global scope. It keeps track ' of group memberships for each user or computer separately.

Dim arrbytGroups, j Dim arrstrGroupSids(), objGroup

objGroupList.Add objADObject.sAMAccountName & "\", True

objADObject.GetInfoEx Array("tokenGroups"), 0 arrbytGroups = objADObject.Get("tokenGroups") If (TypeName(arrbytGroups) = "Byte()") Then ReDim arrstrGroupSids(0) arrstrGroupSids(0) = OctetToHexStr(arrbytGroups) Set objGroup = GetObject("LDAP://<SID=" & arrstrGroupSids(0) _ & ">") objGroupList.Add objADObject.sAMAccountName & "\" _ & objGroup.sAMAccountName, True Exit Sub End If If (UBound(arrbytGroups) = -1) Then Exit Sub End If

ReDim arrstrGroupSids(UBound(arrbytGroups)) For j = 0 To UBound(arrbytGroups) arrstrGroupSids(j) = OctetToHexStr(arrbytGroups(j)) Set objGroup = GetObject("LDAP://<SID=" & arrstrGroupSids(j) _ & ">") objGroupList.Add objADObject.sAMAccountName & "\" _ & objGroup.sAMAccountName, True Next

End Sub

Function OctetToHexStr(ByVal arrbytOctet) ' Function to convert OctetString (byte array) to Hex string.

Dim k OctetToHexStr = "" For k = 1 To Lenb(arrbytOctet) OctetToHexStr = OctetToHexStr _ & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2) NextEnd Function

'------------------------------------------------------------------

В результате выполнения скрипта имеем документ в EXCEL, который сразу можно отправлять на принтер:

Некоторые особенности:1) Значение некоторых свойств и методов можно подсмотреть в режиме записи макроса (т.е. записать макрос и посмотреть какие свойства и методы применяются).2) Для запуска скрипта в системе должен быть установлен принтер и компьютер, на котором запускается скрипт, должен быть в домене Active Directory.

daydevnull.blogspot.com

Как в VBA скрипт для excel вставить проверку по регулярному выражению? — Toster.ru

Всем привет. Пожалуй перейду сразу в общем имеется скрипт (писал не я, помогли) который по определенному признаку (коды оператора, которые указаны в массиве) отделяет мобильные номера в таблице от городских. Скрипт работает отлично, но так как он опирается на скобки возле кода (050), иногда случаются ложные срабатывания. Я хотел бы попросить помощи у тех кто разбирается в VBA, помогите пожалуйста переделать скрипт так, что бы он детектировал номера не по скобочкам, а по следующему регулярному выражению:\b\(?(039|050|063|066|067|068|091|092|093|094|095|096|097|098|099)\)?\s?\-?\d{3}\s?\-?\d{2}\s?\-?\d{2}\b Единственное, я не совсем уверен в верности регулярки, кажется я ошибся с окончанием строки (\b).

Сам скрипт:

Public Sub QWERT() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB M = Array(39, 50, 63, 66, 67, 68, 91, 92, 93, 94, 95, 96, 97, 98, 99) 'закидываем в словарь префиксы For R = 0 To UBound(M) T("(0" & M(R) & ")") = 1 Next R 'считываем в маассив данные With Ëèñò1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2) 'перебираем все строки массива For R = 1 To UBound(M) ' отделяеем название фирмы If InStr(1, M(R, 1), ",") > 0 Then C = Split(M(R, 1), ",")(0) RZ(R, 1) = C RZ(R, 2) = Replace(M(R, 1), C & ",", "") Else RZ(R, 1) = M(R, 1) End If RZ(R, 3) = M(R, 2) ' ищем мобильные операторы U = Split(M(R, 3), ",") For i = 0 To UBound(U) Debug.Print i, UBound(U), U(i), R If T.Exists(Left(U(i), 5)) Then RZ(R, 4) = IIf(RZ(R, 4) = "", U(i), RZ(R, 4) & "," & U(i)) Else RZ(R, 5) = IIf(RZ(R, 5) = "", U(i), RZ(R, 5) & "," & U(i)) End If Next i For i = 4 To UBound(M, 2) RZ(R, i + 2) = M(R, i) Next i Next R Worksheets.Add Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ Cells.Columns.AutoFit Cells.Rows.AutoFit End Sub

Кстати, если это возможно было бы кайфово, если бы при отборе названий фирмы, можно было бы опираться не на первую запятую а на последнюю в строке.

Большое спасибо.

toster.ru

Трюки Excel — MS Excel

Хотя сайт разделен на разделы, перечисленные ниже, вы можете работать с ним разными способами. Один подход заключается в том, чтобы считать сайт набором инструментов и начинать со знакомства с ними в каждом разделе. Затем, если возникает необходимость или проблема, вы просто сможете применить подходящее делу средство. А можно и пролистать разделы или прочитать его статьи от корки до корки, изучая процедуры и скрипты и все больше узнавая Excel. Некоторые из трюков этим и хороши, содержа объяснения сложных тем или хорошо документированные скрипты. Помимо этого, можно просто выбрать один раздел и посмотреть, что в нем полезного для текущей ситуации, а что может пригодиться в будущем.

Упрощение рабочих книг и листов

Рабочие книги и листы — основной интерфейс данных в Excel, но иногда этот набор гигантских открытых таблиц не может выполнить именно то, что вам нужно. Эти трюки позволят управлять взаимодействием пользователей и рабочих листов, помогут найти и выделить информацию и научат справляться с хламом и искажениями.

Перейти к разделу

Трюки со встроенными возможностями Excel

В Excel есть много встроенных средств анализа и управления данными. Однако они зачастую бывают чем-нибудь ограничены. Трюки этой главы помогут расширить и автоматизировать такие функции, выходя за пределы ограниченных задач, для выполнения которых они и были первоначально предназначены.

Перейти к разделу

Трюки с именованием

Хотя ссылки на ячейки вида А2 и IV284:IN1237 определенно бывают полезны, с увеличением электронных таблиц становится проще ссылаться на информацию по имени. Эти трюки демонстрируют не только, как именовать ячейки и диапазоны, но и как создавать имена, приспособленные к данным таблицы.

Перейти к разделу

Трюки со сводными таблицами

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

Перейти к разделу

Трюки с диаграммами

Встроенные функции Excel для создания диаграмм весьма полезны, но не всегда могут обеспечить лучший способ просмотра данных таблицы. Трюки научат настраивать и комбинировать встроенные функции Excel при создании пользовательских диаграмм.

Перейти к разделу

Трюки с формулами и функциями

Формулы и функции лежат в основе большинства электронных таблиц, по иногда способ их обработки в Excel не вполне удовлетворителен. Эти трюки посвящены различным темам — от перемещения формул до решения проблем с типами данных и улучшения времени пересчета.

Перейти к разделу

Трюки с макросами

Макросы (и VBA) — это аварийный выход из Excel; они позволяют конструировать электронные таблицы, выходящие за пределы собственных возможностей Excel, и разрабатывать таблицы, больше похожие на программы. Трюки этого раздела научат максимально эффективно работать с макросами, от управления ими до применения для расширения других возможностей.

Перейти к разделу

excel2010.ru