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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 244 След.
Как сцепить несколько значений в одну ячейку по критерию?
 
Код
Sub UniqFIO()
Dim i As Long
Dim iLastRow As Long
Dim dic As Object
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set dic = CreateObject("scripting.dictionary"): dic.comparemode = 1
  For i = 1 To iLastRow 'собираем уникальные A_B_C в словарь с суммированием
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value & "_" & Cells(i, "C").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value & "_" & Cells(i, "C").Value)) + Cells(i, "D") 'сумма в dic.items
  Next
  [F1].Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
End Sub
Макрос на выборку данных из таблицы с дальнейшей подстановкой в строку рядом с критерием
 
Цитата
создать макрос.
Код
Sub Kontragent_Dogovor()
Dim iLastRow As Long
Dim i As Long
Dim Kontragent As String
Dim FoundKontragent As Range
Dim FirstAdres As String
Dim j As Integer
  iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
    Range("G3:J" & iLastRow).ClearContents
  For i = 3 To iLastRow
    Kontragent = Cells(i, "F")
Set FoundKontragent = Columns(1).Find(Kontragent, , xlValues, xlWhole)
    If Not FoundKontragent Is Nothing Then     'нашли
        FirstAdres = FoundKontragent.Address   'адрес первого вхождения
          j = 7
        Do
            Cells(i, j) = FoundKontragent.Offset(, 1)
          Set FoundKontragent = Columns(1).FindNext(FoundKontragent)
            j = j + 1
        Loop While FoundKontragent.Address <> FirstAdres
    End If
  Next
End Sub
Копирование строк из одного файла и вставка в строку под данными в другой
 
Цитата
только диапазон столбцов C:Y
Код
 Worksheets(1).Range("C2:Y" & r).Copy _
    wb2.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
Вывод уникального списка Начальников и подсчет количества задействованных специальностей в разрезе каждого титула для начальника, , формирование таблицы по определённому шаблону с помощью макроса
 
Кросс http://www.excelworld.ru/forum/10-46332-1
У вас нет в книге листа Сегодня, а вы к нему обращаетесь
Код
Set TodaySht = Worksheets("Сегодня")
Изменено: Kuzmich - 25 ноя 2020 11:20:17
Поиск телефона в диапозоне, Создание макроса
 
В модуль Лист1
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("L2")) Is Nothing Then
   Application.EnableEvents = False
Dim i As Long
Dim iLastRow As Long
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   For i = 2 To iLastRow
     If Target >= Cells(i, "F") And Target <= Cells(i, "G") Then
       MsgBox "Введенный номер попадает в диапазон в строке: " & i & " регион: " & Cells(i, "H")
       Exit For
     End If
   Next
     If i > iLastRow Then
      MsgBox "Нет такого номера в диапазонах столбцов F и G"
          Application.EnableEvents = True
       Exit Sub
     End If
 End If
   Application.EnableEvents = True
End Sub
Поиск телефона в диапозоне, Создание макроса
 
Там везде один регион, так что выводить?
Извлечение данных из ячейки с большим объемом данных, Извлечение данных
 
Цитата
о чем в Едином государственном реестре недвижимости
у вас три даты 10.08.2006 , 25.06.2019 и 03.04.2018
Почему выделена только одна дата?
Для площади
UDF
Код
Function GetSq_total(cell As Range) As String
Dim t As String
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "(является собственником квартиры общей площадью )(\d+,\d+ кв. м)"
       GetSq_total = .Execute(cell)(0).Submatches(1)
    End With
End Function
Function GetSq(cell As Range) As String
Dim t As String
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "(является собственником квартиры площадью жилого помещения )(\d+,\d+ кв. м)"
       GetSq = .Execute(cell)(0).Submatches(1)
    End With
End Function
Изменено: Kuzmich - 23 ноя 2020 19:52:02
Отображение результатов автофильтра в listbox
 
Цитата
чтобы в Listbox2 отображались уникальные отобранные результаты столбца F.
Код
Private Sub Listbox1_Click()
    Range("F:F").AutoFilter Field:=7, Criteria1:=Listbox1.Column(0)
Dim FilteredRng As Range
Dim rng As Range
Dim dict As Object
    With ActiveSheet.AutoFilter.Range
      Set FilteredRng = .Offset(1).Columns("F").Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
      Set dict = CreateObject("scripting.dictionary")
        For Each rng In FilteredRng
           dict.Item(CStr(rng)) = dict.Item(CStr(rng)) + 1
        Next
        Listbox2.List = dict.Keys
    End With
End Sub
Максимальные расстояния между одинаковыми знаками строки
 
Цитата
Для знака i
UDF
Код
Function Kol_vo(cell As String) As Integer
Dim mo As Object
Dim n As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .MultiLine = True
   .Pattern = "i[^i]+i"
     If .test(cell) Then
       Set mo = .Execute(cell)
         Kol_vo = Len(mo(0)) - 2
       For n = 1 To mo.Count - 1
         If Len(mo(n)) - 2 > Kol_vo Then
           Kol_vo = Len(mo(n)) - 2
         End If
       Next
    End If
 End With
End Function
Как вытянуть номер конкретного слова из ячейки (Формула)
 
Цитата
медведь уже на календарь смотрит
Это что? В спячку пора?
Как вытянуть номер конкретного слова из ячейки (Формула)
 
Цитата
вытянуть номер конкретного слова из ячейки
Я формулой не умею
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim arr
Dim n As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    arr = Split(Cells(i, "A"), " ")
    For n = 0 To UBound(arr)
      If arr(n) Like "*блоко*" Then
        Cells(i, "B") = n + 1: Exit For
      Else
        Cells(i, "B") = 0
      End If
    Next
    For n = 0 To UBound(arr)
      If arr(n) Like "*рбуз*" Then
        Cells(i, "C") = n + 1: Exit For
      Else
        Cells(i, "C") = 0
      End If
    Next
  Next
End Sub
Макрос для поиска точного совпадения из ячейки в заданом диапазоне
 
Код
       Set FoundCell = Range("B6:B10404").Find(Cells(1, "E"), , xlValues, xlWhole)
Поиск в столбце уникальных номеров документов, создание одноименных листов и перенос на них данных
 
Тема: Поиск в столбце уникальных номеров документов, создание одноименных листов и перенос на них данных
Оставьте в книге только один Лист1 и запустите макрос
Код
Sub ww()
Dim iLastRow As Long
Dim i As Long
Dim n As Integer     'количество позиций
Dim FoundNomer As Range
Dim FAdr As String
Dim Mesto As String
Dim List1 As Worksheet
    Set List1 = ThisWorkbook.Worksheets("Лист1")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Columns("I").ClearContents
  Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, , Range("I1"), True
  Range("I1") = "Уникальные"
  iLastRow = Cells(Rows.Count, "I").End(xlUp).Row
   For i = 2 To iLastRow
     Worksheets.Add After:=Worksheets(Worksheets.Count)    'добавляем лист
     With List1
       ActiveSheet.Name = .Cells(i, "I")                    'присваиваем имя номера
         n = 0
         Mesto = ""
       Set FoundNomer = .Columns(1).Find(.Cells(i, "I"), , xlValues, xlWhole)
        FAdr = FoundNomer.Address
        Do
          n = n + 1
          Mesto = Mesto & .Cells(FoundNomer.Row, "B") & "(" & .Cells(FoundNomer.Row, "E") & "*" & _
                .Cells(FoundNomer.Row, "F") & "*" & .Cells(FoundNomer.Row, "G") & "*" & " м), "
          Set FoundNomer = .Columns(1).FindNext(FoundNomer)
        Loop While FoundNomer.Address <> FAdr
        Range("A1") = "Номер"
        Range("A2") = "Общее количество"
        Range("A3") = "Перечисление мест"
        Range("B1") = ActiveSheet.Name
        Range("B2") = n
        Range("B3") = Left(Mesto, Len(Mesto) - 2)
        Columns("A:B").AutoFit
     End With
       List1.Activate
   Next
End Sub
Действие макроса на все ячейки в столбце
 
Цитата
как сделать Действие макроса на все ячейки в столбце
Код
Sub iReplace()
   Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row).Replace What:="картофель", Replacement:=""
End Sub
Изменено: Kuzmich - 14 ноя 2020 14:17:13
Как сделать одной функцией, поиск только цифры и поиск по количеству знаков одновременно, Функция поиска по цифрам с количеством символом в тексте
 
Goldenito, написал
Цитата
(A1;3) набираю он берет 601343 и оставляет 601 а должно быть 0 или пусто
Цитата
ставишь 3 он берет из 6 тоже, но режет до 3х
Видимо вам надо так
Код
Function Найтицифрыпоколичеству(r, n)
  With CreateObject("VBScript.RegExp")
    .Pattern = "\b\d{" & n & "}\b"
    If .test(r) Then
      Найтицифрыпоколичеству = .Execute(r)(0)
    Else
      Найтицифрыпоколичеству = "Нет в ячейке " & n & "-значного числа"
    End If
  End With
End Function
Поиск в столбце уникальных номеров документов, создание одноименных листов и перенос на них данных
 
Цитата
Как выглядит кусок кода который анализирует столбец "Номер строки" выделяет от туда все повторные значения
Код
Sub ww()
   Range("A1:A14").AdvancedFilter xlFilterCopy, , Range("I1"), True
   Range("I1") = "Уникальные"
End Sub

В столбце I будут уникальные значения
Задача определения и отбора чисел соответствующим определенным критериям из имеющегося списка
 
Попробуйте UDF
Код
Function iDigits5(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "1(\d)\1{4}"
    If .test(cell) Then
      iDigits5 = "1"
    Else
      .Pattern = "([1])\1{2}([2-9])\2{2}"
      If .test(cell) Then
        iDigits5 = "2"
      Else
        iDigits5 = "0"
      End If
    End If
 End With
End Function
Преобразовать для последующей сортировки текстовую дату в числовую, Нужна формула либо способ сортировки даты
 
Цитата
текстовую дату в числовую
UDF
Код
Function toDate(str As String) As Date
    toDate = CDate(Replace(str, "г.", ""))
End Function
Создать столбец на основе данных из других листов
 
Цитата
способ заполнить его уникальными значениями из других листов?
Цикл по всем листам,  кроме Главный список
Для подсчета уникальных использовать два словаря
Выгрузить на лист Главный список
Выделение Фамилии и инициалов из текста
 
UDF
Код
Function iFIO(cell$)
 With CreateObject("VBScript.RegExp")
   .Pattern = "[А-ЯЁ][а-яё]+ [А-ЯЁ]\. [А-ЯЁ]\.?"
   If .test(cell) Then
     iFIO = .Execute(cell)(0)
   Else
     iFIO = ""
   End If
 End With
End Function
Динамическая сортировка участников по убыванию итоговых баллов
 
Цитата
в зависимости от итоговых баллов участники сортировались по убыванию
Запустить макрос
Код
Sub SortTablica()
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
   Range("A3:O" & iLastRow).Sort Key1:=Range("O3"), Order1:=xlDescending, Header:=xlNo
End Sub
Удалить часть символов с конца строки
 
Цитата
данный код я добавляю в макрос.
Данный код вы добавляете в стандартный модуль
А дальше
Цитата
Затем прописываю =iAdres(ячейка)
Удалить часть символов с конца строки
 
Цитата
после номера дома, необходимо удалить.
UDF для вашего примера
Код
Function iAdres(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "([А-Яёа-яё_]+){2}\d+"
     iAdres = .Execute(cell)(0)
 End With
End Function
Нужно сделать разрывы (пустые строки) между блоками данных по 30 строк
 
я тоже не понимаю
Цитата
нужно сделать по 30 строк
и далее
Цитата
в промежутках должно быть от 1 до 74
Сортировка и подсчет количества повторяющихся данных, Формула работает не правильно, помогите пож-ста...
 
При активном листе PRINTER запустить макрос
Код
Sub DelDublCartrid()
Dim i As Long
Dim iLastRow As Long
Dim dict As Object
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set dict = CreateObject("Scripting.Dictionary")
   Range("D1:E" & iLastRow).ClearContents
   Range("D1") = "Картридж"
   Range("E1") = "Количество"
 For i = 2 To iLastRow
   If Cells(i, "A") <> "" Then
     dict.Item(CStr(Cells(i, "A"))) = dict.Item(CStr(Cells(i, "A"))) + 1
   End If
 Next
   Range("D2").Resize(dict.Count, 2) = Application.Transpose(Array(dict.Keys, dict.Items))
End Sub

Результат в столбцах D и E
Формирование нумерации каждой партии для печати
 
Цитата
возможно это будет макрос
Формирует на том же листе
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = iLastRow To 2 Step -1
    n = Cells(i, "B")
    Range("A" & i + 1 & ":B" & i + 1).EntireRow.Resize(n - 1).Insert
    Range("A" & i & ":B" & i).Resize(n).FillDown
    Range("B" & i) = 1
     Range("B" & i).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
       Step:=1, Stop:=n, Trend:=False
  Next
End Sub
Получить согласные буквы
 
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=114221
Поиск символа в ячейке и его замена, Необходимо заменить Р на Х, учитывая регистр, т.е если Р заглавная, то и Х заглавная и наоборот.
 
UDF  в стандартный модуль
В А1 текст, в В1 вставляете =iReplace(A1)
Поиск символа в ячейке и его замена, Необходимо заменить Р на Х, учитывая регистр, т.е если Р заглавная, то и Х заглавная и наоборот.
 
Для Rus
Код
Function iReplace(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "Р"
     iReplace = .Replace(cell, "Х")
 End With
End Function
Поиск символа в ячейке и его замена, Необходимо заменить Р на Х, учитывая регистр, т.е если Р заглавная, то и Х заглавная и наоборот.
 
Цитата
в ячейке найти букву  Р и заменить ее на Х
Какой алфавит Rus или Lat ?
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 244 След.
Наверх