Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 34 След.
Где брать практические задачи для VBA
 
Реализация различных алгоритмов на VBA:
- поиск элемента/списка (массива) в другом массиве/диапазоне
- поиск подстроки в строке
- сортировка данных

Ну и пр....
Извлечение части текста из строк с переносом извлеченых фрагментов в другой столбец и формированием из них уникального списка
 
...
Код
Sub aaaaa()
Dim DC As Object, a&, arr(), dd(), aa$, dt$
Set DC = CreateObject("Scripting.Dictionary")
With ActiveSheet
  arr = .Range("B4:C42").Value
  For a = 1 To UBound(arr)
    If Len(arr(a, 1)) > 0 Then
      aa = Split(arr(a, 1), "/")(0)
      If InStr(aa, "100% ORGANIC") Then
        dt = Mid(aa, InStr(InStr(InStr(1, aa, " ") + 1, aa, " ") + 1, aa, " ") + 1)
      Else: dt = aa
      End If
      DC.Item(dt & "*" & arr(a, 2)) = arr(a, 2)
    End If
  Next: ReDim arr(1 To DC.Count, 1 To 2): dd = DC.keys()
  For a = 1 To DC.Count
    arr(a, 1) = Split(dd(a - 1), "*")(0): arr(a, 2) = Split(dd(a - 1), "*")(1)
  Next
  .[B44].Resize(DC.Count * 2, 2).ClearContents
  .[B44].Resize(DC.Count, 2) = arr
End With
End Sub
Извлечение части текста из строк с переносом извлеченых фрагментов в другой столбец и формированием из них уникального списка
 
Т.к. данные (если они будут друг над другом: оригинал и итоговый список), то в начале нужно указывать жесткий диапазон при взятии диапазона с листа в массив. Иначе получится ерунда и макрос заберет в массив все данные по двум столбцам по последнюю заполенную ячейку "В" включительно со всеми вытекающими.

П.С.: чтобы закомментировать кусок кода нужно перед ним поставить одинарную кавычку.
Извлечение части текста из строк с переносом извлеченых фрагментов в другой столбец и формированием из них уникального списка
 
Формулами может и можно, но это не ко мне) Выгрузка туда-же, откуда взяли данные. Если нужно ниже , то в конце кода измените адрес выгрузки и закомментируйте ".ClearContents"
Код
Sub aaaaa()
Dim DC As Object, a&, arr(), dd(), aa$, dt$
Set DC = CreateObject("Scripting.Dictionary")
With ActiveSheet
  a = .Cells(.Rows.Count, "B").End(xlUp).Row
  With .Range("B4:C" & a)
    arr = .Value: .ClearContents
  End With
  For a = 1 To UBound(arr)
    If Len(arr(a, 1)) > 0 Then
      aa = Split(arr(a, 1), "/")(0)
      If InStr(aa, "100% ORGANIC") Then
        dt = Mid(aa, InStr(InStr(InStr(1, aa, " ") + 1, aa, " ") + 1, aa, " ") + 1)
      Else: dt = aa
      End If
      DC.Item(dt & "*" & arr(a, 2)) = arr(a, 2)
    End If
  Next: ReDim arr(1 To DC.Count, 1 To 2): dd = DC.keys()
  For a = 1 To DC.Count
    arr(a, 1) = Split(dd(a - 1), "*")(0): arr(a, 2) = Split(dd(a - 1), "*")(1)
  Next
  .[B4].Resize(DC.Count, 2) = arr
End With
End Sub
Изменено: Anchoret - 9 Окт 2019 11:43:13
Извлечение части текста из строк с переносом извлеченых фрагментов в другой столбец и формированием из них уникального списка
 
Код
Sub aaaaa()
Dim DC As Object, a&, arr(), dd(), aa$, dt$
Set DC = CreateObject("Scripting.Dictionary")
With ActiveSheet
  a = .Cells(.Rows.Count, "A").End(xlUp).Row
  arr = .Range("A2:B" & a).Value
  For a = 1 To UBound(arr)
    aa = Split(arr(a, 1), "/")(0)
    If InStr(aa, "100% ORGANIC") Then
      dt = Mid(aa, InStr(InStr(InStr(1, aa, " ") + 1, aa, " ") + 1, aa, " ") + 1)
    Else: dt = aa
    End If
    DC.Item(dt & "*" & arr(a, 2)) = arr(a, 2)
  Next: ReDim arr(1 To DC.Count, 1 To 2): dd = DC.keys()
  For a = 1 To DC.Count
    arr(a, 1) = Split(dd(a - 1), "*")(0): arr(a, 2) = Split(dd(a - 1), "*")(1)
  Next
  .[H2].Resize(DC.Count, 2) = arr
End With
End Sub
Как записать высчитанный макросом диапазон в формулу Excel?
 
В качестве примера:
Код
Sub aaaa()
Dim sRow&, lRow&
With ActiveSheet
  sRow = Intersect(.Columns(1), .UsedRange).Row
  lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  .[B1].Formula = "=Sum(A" & sRow & ":A" & lRow & ")"
End With
End Sub
Изменено: Anchoret - 9 Окт 2019 09:36:09
макрос excel на анализ входящей почты outloock и отправку файла excel
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
Да и судя по описанию планируется не таблицу в письмо вставлять, а файл Excel.
+ (насколько я понял) еще проверять на соответствие адресата из входящего письма определенной группе рассылки. Группы пока не искал, но наверняка и это возможно. Надо поковырять объект Outlook)
----------
Порылся, но ничего относящегося к группам рассылок не нашел. Возможно они на главном сервере компании.
Изменено: Anchoret - 8 Окт 2019 18:55:19
Собрать все email в одну ячейку по каждой компании в отдельности
 
Формулы - это не ко мне.
макрос excel на анализ входящей почты outloock и отправку файла excel
 
Дмитрий(The_Prist) Щербаков, во всяком случае таблицы из Excel вставленные в тело письма в HTML формате)
БМВ, так для фильтрации массива писем в Outlook же есть встроенный инструмент - "Правила" + возможность создавать папки и пр.. Хотя кому я рассказываю, Вы и так все это лучше меня знаете)
Собрать все email в одну ячейку по каждой компании в отдельности
 
Код
Sub aaaaa()
Dim DC As Object, arr(), dd(), b&
With ActiveSheet
  b = .Cells(.Rows.Count, "A").End(xlUp).Row
  arr = .Range("A3:B" & b).Value
  Set DC = CreateObject("Scripting.Dictionary")
  For b = 1 To UBound(arr)
    If Not DC.exists(arr(b, 1)) Then
      ReDim dd(1 To 1): dd(1) = arr(b, 2): DC.Add arr(b, 1), dd
    Else
      dd = DC.Item(arr(b, 1)): ReDim Preserve dd(1 To UBound(dd) + 1)
      dd(UBound(dd)) = arr(b, 2): DC.Item(arr(b, 1)) = dd
    End If
  Next: arr = DC.keys
  For b = 0 To UBound(arr)
    .Cells(b + 3, "E") = arr(b)
    .Cells(b + 3, "F") = Join(DC.Item(arr(b)), ";")
  Next
End With
End Sub
макрос excel на анализ входящей почты outloock и отправку файла excel
 
Подобным макаром можно по запросу (кнопке) шерстить папки Outlook из Excel:
Код
Sub ReadOutMail()
Dim fld As Object
Set fld = CreateObject("Outlook.Application")
Set aa = fld.Session.CurrentUser.Session.Folders
For Each bb In aa
  For Each cc In bb.Folders
    Debug.Print cc.Name
    For Each dd In cc.Items
      If InStr(dd.Subject, "Нужная тема") > 0 Then 'выбираем тему письма
        Debug.Print dd.Subject & " " & dd.CreationTime
        Debug.Print dd.Attachments.Count
        ' здесь какой-то код по обработке
      End If
    Next
  Next
Next
End Sub

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

Все содержимое писем в Outlook в HTML формате, насколько я знаю. Это на случай если потребуется ковырять тело писем, то потребуется парсер.
Изменено: Anchoret - 8 Окт 2019 17:39:36
Проблема при работе PasteSpecial в 2013 Excel VBA. Ошибка PasteSpecial
 
Точку не пробовали ставить в начале первой строки после With?
Экспорт в .txt определенного диапазона по заданным условиям
 
Как-то многострочно вышло...
Код
Sub bbbb()
Dim dt$, a&, b&, c&, aa As Range, bb As Range, cc(), x&
Set bb = ActiveSheet.Range("E3:P18") 'диапазон меняем здесь
c = FreeFile: a = bb.Row
dt = ThisWorkbook.Path & "\" & Replace(Replace(Now, ".", "_"), ":", "_") & ".txt"
For Each aa In bb
  If InStr(aa, "\") Then
    If Len(aa) > x Then x = Len(aa)
  End If
Next
Open dt For Output As #c
  For a = 1 To bb.Rows.Count
    ReDim cc(1 To bb.Columns.Count): b = 1
    For Each aa In Intersect(bb, bb.Rows(a)).Cells
      If InStr(aa, "\") Then
        cc(b) = aa.Value & Space(x - Len(aa)): b = b + 1
      ElseIf InStr(aa.NumberFormat, "yy") Or InStr(aa.NumberFormat, "hh") Then
        cc(b) = Format(aa, aa.NumberFormat): b = b + 1
      Else: cc(b) = aa.Value: b = b + 1
      End If
    Next: dt = Join(cc, "")
    If Len(dt) > 0 And InStr(dt, "\.") < 1 Then Print #c, Join(cc, vbTab)
  Next
Close #c
End Sub
Изменено: Anchoret - 7 Окт 2019 15:45:04 (укоротил...)
Заполнение циклом имен кнопок формы
 
Подправленный код формы:
Код
Private Sub UserForm_Initialize()
ButtonNames
End Sub

Private Sub ButtonNames()
Dim aTtm()

'Me("CommandButton" & iCount).Caption = "1"' переменная iCount инициируется лишь в цикле ниже - ошибка номер раз
'Dim aTtm as Date' в переменную типа Date запихиваем массив строкой ниже - ошибка номер два
aTtm = Sheets("Today").Range("D4:D34").Value  'массив наименований работ сегодня
For iCount = 1 To 31
  Me.Controls("CommandButton" & iCount).Caption = aTtm(iCount, 1) 'если да то название кнопки равно текущему дню в числовом формате
Next

End Sub

Вообще складывается ощущение , что макрос был откуда-то выдран, а вот подкорректировать его забыли
Макрос который будет искать диапазон данных и переносить их на другой лист
 
Файл-пример, где "как есть" и "как надо".
Макрос поиска максимального цифрового значения из диапазона данных с комбинированными значениями
 
Код
Sub aaaa()
Dim aa, a&, b#
aa = Array("SQ001", "SQ007", "SQ023", "SQ017", "SQ123")
For a = 0 To UBound(aa)
  If CDbl(Mid$(aa(a), 3)) > b Then b = CDbl(Mid$(aa(a), 3))
Next
Debug.Print b
End Sub
Найти совпадения в двух списках по позициям и ценам
 
Файл-пример?
Найти совпадения в двух списках по позициям и ценам
 
Сортировка по артикулам в обоих списках + СЧЁТЕСЛИ c фильтром по >0 и 0.
Макрос копирование диапазона на другой лист с изменением размера шрифта
 
Код
Sub В_Отчет()
Dim Ar As Range, aa As Range
 Set Ar = Worksheets("Отчет").Range("A11")
 Set aa = [A16:C40]
aa.Copy Destination:=Ar
Ar.Resize(aa.Rows.Count, aa.Columns.Count).Font.Size = 12
End Sub
Автоматическое заполнение второго табеля, ежедневно приходится заполнять два табеля с одинаковыми значениями, но в разных таблицах
 
Просматривает объединенные диапазоны на листе-доноре в столбце "D"
Если номер техники в наличии, то ищет его на листе-получателе в столбце "Е"
Если найден, то переносит вместе с форматированием содержимое табеля по двум сменам на листе-доноре
Код
Sub aaaa()
Dim aa As Range, a&, sh1 As Worksheet, sh2 As Worksheet, dt$
Set sh1 = Sheets("табельЗП"): Set sh2 = Sheets("техтабель")
a = 10
Do While sh2.Cells(a, "D").MergeCells And Len(sh2.Cells(a, "D")) > 0
  dt = sh2.Cells(a, "D")
  Set aa = sh1.UsedRange.Columns("E").Find(dt, , xlValues, xlPart, xlByColumns, xlNext)
  If Not aa Is Nothing Then
    Intersect(sh2.Columns("F:AJ"), sh2.Rows(a + 1)).Copy sh1.Range("H" & aa.Row)
    Intersect(sh2.Columns("F:AJ"), sh2.Rows(a + 3)).Copy sh1.Range("H" & aa.Row + 1)
    Intersect(sh2.Columns("F:AJ"), sh2.Rows(a + 5)).Copy sh1.Range("H" & aa.Row + 4)
    Intersect(sh2.Columns("F:AJ"), sh2.Rows(a + 7)).Copy sh1.Range("H" & aa.Row + 5)
  End If
  a = a + sh2.Cells(a, "D").MergeArea.Rows.Count
Loop

End Sub
Автоматическое заполнение второго табеля, ежедневно приходится заполнять два табеля с одинаковыми значениями, но в разных таблицах
 
В [F1]
Код
=H5
и так далее.
Отправка письма в Excel, В коде VB не заносятся эл.адрес получателя и тема
 
Код
Cells(i, 1).Value
Необходимо перенести с условием строки
 
Код
Option Explicit

Sub Test()
Dim iCell As Range, Priznak As Variant, a&, f As Boolean
    
    Priznak = Array("c", "a")
    For Each iCell In Range("A2", [A2].End(xlDown)) 'цикл по всем ячейкам А2 и ниже
      f = 0
      For a = LBound(Priznak) To UBound(Priznak)
        If StrComp(iCell, Priznak(a), 1) = 0 And Not f Then
            With Sheets("Лист2") 'копируем на Лист2
                iCell.EntireRow.Copy Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
            End With: f = 1
        End If
      Next
    Next iCell
End Sub
Замена СчетЕсли при подсчёте количества звонков., Нужно придумать альтернативу формуле СЧЕТЕСЛИ
 
На 1кк номеров справляется за 1,9 сек (только сортировка) на рабочем компе.
Из "Е" столбца выбирает номера телефонов, превращает их в числа, сортирует, считает дубли, выгружает в столбец "I" список повторов.
Код
Type mDbl: d As Double: End Type
Type bArr: b(7) As Byte: End Type

Sub Idx()
Dim Arr(), qq(), aa&(), a&, b&, c&
With ActiveSheet
  a = .Cells(.Rows.Count, "E").End(xlUp).Row
  Arr = .Range("E2:E" & a).Value: ReDim qq(1 To UBound(Arr), 1 To 1)
  For a = 1 To UBound(Arr): Arr(a, 1) = CDbl(Mid$(Arr(a, 1), 2)): Next
  i = Timer
  NumSort Arr(), 1, aa()
  Debug.Print Timer - i
  For a = 1 To UBound(Arr) - 1
    b = 1: qq(a, 1) = b
    Do While Arr(aa(a), 1) = Arr(aa(a + 1), 1)
      qq(aa(a), 1) = b: b = b + 1: a = a + 1
      If a = UBound(Arr) Then Exit Do
    Loop
  Next: qq(aa(a), 1) = b
  .[I2].Resize(a, 1) = qq
End With
End Sub

Sub NumSort(Arr(), ByVal n&, aa&())
Dim bMap(), bb() As bArr, d As mDbl, m&, p&
Dim a&, b&, c&, dd&(), x&, xx&
'------------------------------------------------------
ReDim bb(1 To (UBound(Arr) - LBound(Arr) + 1)): ReDim dd(LBound(Arr) To UBound(Arr))
x = LBound(Arr) And 1 Xor 1
For a = LBound(Arr) To UBound(Arr)
  d.d = Arr(a, n): LSet bb(a + x) = d: dd(a) = a
  If bb(a + x).b(7) And 128 Then m = m + 1 Else p = p + 1
Next
For a = 3 To 7: ReDim bMap(0 To 255): c = 0
  For b = LBound(dd) To UBound(dd)
    bMap(bb(dd(b)).b(a)) = bMap(bb(dd(b)).b(a)) + 1
  Next
  For b = LBound(dd) To UBound(dd)
    If IsArray(bMap(bb(dd(b)).b(a))) Then
      bMap(bb(dd(b)).b(a))(0) = bMap(bb(dd(b)).b(a))(0) + 1: bMap(bb(dd(b)).b(a))(bMap(bb(dd(b)).b(a))(0)) = dd(b)
    Else: ReDim aa(0 To bMap(bb(dd(b)).b(a))): aa(0) = 1: aa(1) = dd(b): bMap(bb(dd(b)).b(a)) = aa
    End If
  Next: xx = LBound(dd)
  For b = 0 To 255
    If IsArray(bMap(b)) Then
      For c = 1 To bMap(b)(0): dd(xx) = bMap(b)(c): xx = xx + 1: Next
    End If
  Next
Next: Erase bMap: aa = dd: p = m + 1
For a = LBound(dd) To UBound(dd)
  If bb(dd(a)).b(7) And 128 Then aa(m) = dd(a): m = m - 1 Else: aa(p) = dd(a): p = p + 1
Next: dd = aa
For a = 2 To UBound(aa): x = a
  Do While Arr(dd(x - 1), n) > Arr(aa(a), n)
    dd(x) = dd(x - 1): x = x - 1
    If x = 1 Then Exit Do
  Loop
  dd(x) = aa(a)
Next: aa = dd: Erase dd
End Sub
Как перенести данные одной ячейки во вторую
 
Собирает данные по всему столбцу "D":
Код
Sub aaaa()
Dim aa As Range, DC As Object
Set DC = CreateObject("Scripting.Dictionary")
For Each aa In ActiveSheet.UsedRange.Columns("D").Cells
  If Len(aa) > 0 Then DC.Item(aa.Value) = aa.Row
Next
[U10] = Join(DC.keys, ",")
End Sub
Изменено: Anchoret - 19 Сен 2019 15:37:51
Макрос выделения нужного текста на странице
 
Образец строки берется из [A1](без попытки интерпретировать значеие относительно формата ячейки):
Код
Sub aaaa()
Dim aa As Range
For Each aa In ActiveSheet.UsedRange.Cells
  If InStr(aa, [A1]) Then
    With aa.Characters(InStr(aa, [A1]), Len([A1]))
      .Font.Color = vbRed: .Font.Bold = True
    End With
  End If
Next
End Sub

С учетом формата , но при чтении и окраске меняет формат на текстовый:
Код
Sub bbbb()
Dim aa As Range, txt$, a&
For Each aa In ActiveSheet.UsedRange.Cells
  txt = Format(aa, aa.NumberFormat)
  If InStr(txt, [A1]) Then
    aa.NumberFormat = "@": aa = txt: a = 1
    Do While InStr(a, txt, [A1])
      With aa.Characters(InStr(a,txt, [A1]), Len([A1]))
        .Font.Color = vbRed: .Font.Bold = True
      End With
      a = a + Len([A1])
    Loop
  End If
Next
End Sub
Изменено: Anchoret - 19 Сен 2019 15:28:12
Макрос спотыкается на #Н/Д
 
Проверить наличие ошибки на листе можно и так:
Код
If VarType(здесь проверяемая ячейка)=10 then

Скрытый текст
Не работает выгрузка из массива в Combobox
 
Изменил название процедуры + убрал тип Date для массива и сортера - из словаря выгрузка ключей и итемов только в вариантные массивы.
Код
Private Sub UserForm_Initialize()
    Dim arrData(), myDictionary As Object, myCell As Range, Sh7 As Worksheet, lLastRow7A As Long
        Set Sh7 = Ëèñò7
        Set myDictionary = CreateObject("Scripting.Dictionary")
            lLastRow7A = Sh7.Cells(Rows.Count, 1).End(xlUp).Row
    
'Îòáîð óíèêàëüíûõ çíà÷åíèé èç äèàïàçîíà
        On Error Resume Next
            For Each myCell In Sh7.Range("A2:A" & lLastRow7A)
                myDictionary.Item(CDate(myCell.Value)) = CDate(myCell.Value)
            Next
        On Error GoTo 0
    
        ReDim Preserve arrData(myDictionary.Count - 1)
        arrData = myDictionary.Items()
            SortAr arrData
            CmB_Date.List = arrData                                         'íå çàïîëíÿåòñÿ êîìáîáîêñ
            CmB_Date.Value = Format(CmB_Date.Value, "ddd dd.mm.yy h:mm")    'íóæåí òàêîé ôîðìàò äàò â êîìáîáîêñå
End Sub
Sub SortAr(arr())
    Dim Temp As Date, i As Long, j As Long
        For j = 2 To UBound(arr)
            Temp = arr(j)
            For i = j - 1 To 1 Step -1
                If (arr(i) <= Temp) Then GoTo 10
                    arr(i + 1) = arr(i)
            Next i
            i = 0
10:         arr(i + 1) = Temp
        Next j
End Sub
Изменено: Anchoret - 8 Сен 2019 12:19:35
Обращение к ячейкам объединенных диапазонов
 
Или так:
Код
Dim rr As Range, a, b
Set rr = Union(Range("A1:A3"), Range("B1:D1"))
a = rr(1, 1)
a = rr(2, 1)
a = rr(3, 1)
'что характерно - можно вылезти за рамки указанного диапазона и считать данные из "E1" (b=rr(1,5)) и на это не выдаст ошибку
b = rr(1, 2)
b = rr(1, 3)
b = rr(1, 4)
Изменено: Anchoret - 6 Сен 2019 00:45:55
Восстановить нумерацию подпунктов VBA
 
Код
Sub ReNum()
Dim c%, arr(), a&, b1&, b2&, dt$, z&
With ActiveSheet
  arr = Intersect(.[A1].CurrentRegion, .Columns(1)).Value: b2 = 1
  For a = 1 To UBound(arr)
    If Left(arr(a, 1), 1) Like "#" Then
      If InStr(arr(a, 1), ")") Then dt = Split(arr(a, 1), ")")(1) Else dt = ""
      If InStr(arr(a, 1), ".") Then c = Val(Split(arr(a, 1), ".")(0)) Else c = Val(arr(a, 1))
      If z = c Then
        arr(a, 1) = b1 & "." & b2 & ")" & dt: b2 = b2 + 1
      Else: b1 = b1 + 1: z = c: arr(a, 1) = b1 & ")" & dt: b2 = 1
      End If
      Else
    End If
  Next
  Intersect(.[A1].CurrentRegion, .Columns(1)) = arr
End With
End Sub
Изменено: Anchoret - 3 Сен 2019 05:27:50
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 34 След.
Наверх