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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 254 След.
Как вытащить из ячейки IP адреса, записанные вместе с текстом?
 
Цитата
цифры что похожи или являются ip нужны все,
Вытаскиваем то, что в квадратных скобках. В первой ячейке убрать в начале скобку.
Код
Function Skobki(cell$) As String
Dim mo As Object
Dim n As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "\[.+?(?=\])"
   Set mo = .Execute(cell)
   For n = 0 To mo.Count - 1
     Skobki = Skobki & Mid(mo(n), 2) & "; "
   Next
 End With
End Function
как извлечь должность и ФИО в одной ячейке таблицы
 
Как пример
как извлечь должность и ФИО в одной ячейке таблицы
 
Д/с "Ягодка"
МБДОУ д/с 78
UDF
Код
Function iDC(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "Д/с (\d+)?"
     If .test(cell) Then
       If .Execute(cell)(0).SubMatches(0) Then
         iDC = .Replace(cell, "Детский сад № $1")
       Else
         iDC = .Replace(cell, "Детский сад ")
       End If
     End If
 End With
End Function

получаем
Детский сад "Ягодка"
МБДОУ Детский сад № 78
как извлечь должность и ФИО в одной ячейке таблицы
 
Посмотрите в файле
как извлечь должность и ФИО в одной ячейке таблицы
 
A1 - художник Иванов Иван Иванович  
UDF  вызов =iFIO(A1)
Код
Function iFIO(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = False
     .Pattern = "([А-ЯЁ][а-яё ]+)([А-ЯЁ])[а-яё ]+([А-ЯЁ])[а-яё ]+"
     If .test(cell) Then
       iFIO = .Replace(cell, "$1$2.$3.")
     End If
 End With
End Function
Как забрать нужное значение после "ключевого слова", Извлечение информации после контрольного слова в ячейке
 
Вот UDF для Тип оборудования:
Код
Function iTip(cell$) As String
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .MultiLine = True
     .Pattern = "Тип оборудования: ([А-ЯЁ ]+)"
   If .test(cell) Then
       iTip = .Execute(cell)(0).SubMatches(0)
   Else
     iTip = ""
   End If
 End With
End Function

Для остальных аналогично
Как забрать нужное значение после "ключевого слова", Извлечение информации после контрольного слова в ячейке
 
Валентин Ненаю,
Не могу найти в вашем примере ни Sku=5575, ни мощности
Где все это?
Оставить в ячейке вторую строку
 
Алекс Семенов, написал
Цитата
не работает Ваш код
Просто вы не умеете его готовить......
Как убрать символы до определенного знака в чередующихся значениях через запятую
 
UDF
Код
Function iJPG_(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "\d{6}//?"
     If .test(cell) Then
       iJPG_ = .Replace(cell, "")
     End If
 End With
End Function
Оставить в ячейке вторую строку
 
Код
Range("A1") = Split(Range("A1"), Chr(10))(1)
Как удалить знаки в конце строки после массива чисел?
 
Александр Лисицын,
Неразрывный пробел в первой строке 8.7.03.05.03.   . оставляет точку в конце
Код
Sub iDelPoint()
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B1:B" & iLastRow).ClearContents
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d\.[^\d]*$"
   For i = 1 To iLastRow
     If .test(Cells(i, 1)) Then
       Cells(i, 2) = Left(Cells(i, 1), .Execute(Cells(i, 1))(0).FirstIndex + 1)
     End If
   Next
 End With
End Sub
Посчитать сколько строк содержат слова, в которых есть заглавные буквы помимо первой.
 
Цитата
в которых есть заглавные буквы помимо первой
UDF показывает количество таких слов в ячейке
Код
Function More2(cell$)
Dim mo As Object
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[А-ЯЁ]{2,}"
   If .test(cell) Then
   Set mo = .Execute(cell)
     More2 = mo.Count
   Else
     More2 = ""
   End If
 End With
End Function
Номер диапазона, в котором находится промежуточное значение
 
Цитата
определить в какой именно диапазон(т.е. строку) я попал, или я все же не в ту сторону думаю?
Код
Sub Diapazon()
Dim i As Long
Dim n As Long
Dim iLastRow As Long
Dim arr
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("B2:B" & iLastRow).ClearContents
   arr = Range("A2:F" & iLastRow).Value
   For i = LBound(arr) To UBound(arr)
     For n = LBound(arr) To UBound(arr)
       If arr(i, 1) >= arr(n, 4) And arr(i, 1) <= arr(n, 5) Then
          arr(i, 2) = arr(n, 6)
          Exit For
       End If
     Next
   Next
   Range("A2").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub
Формула суммы чисел в текстовой строке
 
Цитата
Необходимо суммировать числа в строке
UDF
Код
Function iSumma(cell As String) As Double
Dim arr
Dim i As Integer
  arr = Split(cell, ",")
  For i = 0 To UBound(arr)
    iSumma = iSumma + Val(arr(i))
  Next
End Function
Найти и заменить фрагмент текста макросом
 
Напишу еще один раз для непонятливых, а то New уже не выдержал
Код
Sub iReplace()
' кабинет/операторная
 If InStr(1, Range("B7"), "кабинет", vbTextCompare) > 0 Then Range("B7") = "Р.м. кабинет"
 If InStr(1, Range("B7"), "опер", vbTextCompare) > 0 Then Range("B7") = "Р.м. операторная"
 ' тип ламп
 If InStr(1, Range("E7"), "ЛН", vbTextCompare) > 0 Then Range("E7") = "Лампы накаливания"
 If InStr(1, Range("E7"), "ЛБ", vbTextCompare) > 0 Then Range("E7") = "Люминисцентные лампы"
 If InStr(1, Range("E7"), "LED", vbTextCompare) > 0 Then Range("E7") = "Светодиодные лампы"
 If InStr(1, Range("E7"), "светод", vbTextCompare) > 0 Then Range("E7") = "Светодиодные лампы"
End Sub
Найти и заменить фрагмент текста макросом
 
Код
If InStr(1, Range("E7"), "ЛН", vbTextCompare) > 0 Then Range("E7")= "Лампы накаливания"
         If InStr(1, Range("E7"), "ЛБ", vbTextCompare) > 0 Then Range("E7") = "Люминисцентные лампы"
Найти и заменить фрагмент текста макросом
 
Алекс Семенов, написал
Цитата
Разобрался
Если Set Rng = Range("E7") занимает одну ячейку, то зачем делать цикл
Код
For Each iCell In Rng
Поиск первого значения по условию на vba
 
Цитата
работает и для большего количества имен
Тогда в колонке С будет значение для последнего имени
Поиск первого значения по условию на vba
 
Код
Там будет одинаковое имя

Если одинаковых имен только два, то
Код
Sub PoiskName()
Dim Found_Name As Range
Dim FAdr As String
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To iLastRow
  Set Found_Name = Columns("A").Find(Cells(i, "A"), , xlValues, xlWhole)
    If Not Found_Name Is Nothing Then
      FAdr = Found_Name.Address
      Do
        Set Found_Name = Columns("A").FindNext(Found_Name)
        Cells(i, "C") = Found_Name.Offset(, 1)
      Loop While Found_Name.Address <> FAdr
    End If
Next
End Sub
Поиск первого значения по условию на vba
 
Nazar93,
А имя Сиддоров и Сидово это считается повтор или ошибка ввода?
Перенос данных из ячейки в строки и с копированием строк.
 
Код
Sub RazdelRow()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim arr
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   For i = iLastRow To 2 Step -1
     If InStr(1, Cells(i, "C"), ";") <> 0 Then
       arr = Split(Cells(i, "C"), ";")
     End If
     If InStr(1, Cells(i, "C"), ",") <> 0 Then
       arr = Split(Cells(i, "C"), ",")
     End If
       For n = UBound(arr) To 0 Step -1         'вставляем с конца массива  arr
         Rows(i + 1).Insert
         Cells(i + 1, "C") = arr(n)
         Range("A" & i & ":B" & i).Copy Range("A" & i + 1)
         Range("D" & i).Copy Range("D" & i + 1)
       Next
         Rows(i).Delete
   Next
End Sub
Сортировка не 1,10,11...2.21, а адекватная 1,2,3, изменить принцип сортировки
 
UDF
Код
Function iMarka1(cell$)
  If Len(Split(Split(cell, " ")(1), "*")(0)) = 1 Then
    iMarka1 = Split(cell, " ")(0) & " 0" & Split(cell, " ")(1)
  Else
    iMarka1 = cell
  End If
End Function
Как перенести содержимое одной ячейки в несколько разных?
 
Цитата
перенести номер задачи и описание в разные ячейки как в зеленой таблице.
Может так
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "H").End(xlUp).Row
 Range("A2:B" & 2 * iLastRow).ClearContents
  For i = 2 To iLastRow
      Cells(2 * i - 2, "A") = Split(Split(Cells(i, "H"), Chr(10))(0), " ")(0)
      Cells(2 * i - 2, "B") = Split(Split(Cells(i, "H"), Chr(10))(0), " ", 2)(1)
      Cells(2 * i - 1, "A") = Split(Split(Cells(i, "H"), Chr(10))(1), " ")(0)
      Cells(2 * i - 1, "B") = Split(Split(Cells(i, "H"), Chr(10))(1), " ", 2)(1)
  Next
End Sub
Изменено: Kuzmich - 31 мар 2021 20:47:28
Копирование ячеек на другой лист с проставлением даты и времени внесённых изменений.
 
Цитата
новое занесение спускается на 1 строчку вниз и это будет не удобно
Новое значение заносите в 3-ю строку
Код
    With ThisWorkbook.Sheets("2450х1250")
    'в Юнионе перечислите ячейки которые должны быть скопированы
        .Rows(3).Insert
        Excel.Application.Union(Me.Cells(iRow, 2), Me.Cells(iRow, 1)).Copy .Range("A3")
'        .Cells(.Columns(1).End(xlDown).Row + 1, 1)
    End With
Нахождение и извлечение всех номеров согласно заданной должности
 
Код
Sub test()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("F1:F" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("A4:B" & iLastRow).Value
  For i = 1 To UBound(arr)
    dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & arr(i, 2) & ","
  Next i
   Range("F4").Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.Items))
End Sub
Макрос выделения цветом строки
 
Код
Set CrossRange = Intersect(WorkRange, Target.EntireRow)
Преобразовать в дни нестандартную форму времени
 
Цитата
направление в котором нужно искать.
Код
Sub Tabl_Days()
Dim i As Long
Dim iLastRow As Long
Dim iDays As Integer
Dim iHour As Integer
Dim iMin As Integer
Dim TimeInDays As Double
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With CreateObject("VBScript.RegExp")
   .Pattern = "(\d+д)?(\d+ч)?(\d+мин)?"
  For i = 2 To iLastRow
    iDays = Val(.Execute(Cells(i, "A"))(0).SubMatches(0))
    iHour = Val(.Execute(Cells(i, "A"))(0).SubMatches(1))
    iMin = Val(.Execute(Cells(i, "A"))(0).SubMatches(2))
    TimeInDays = WorksheetFunction.RoundUp((iDays + iHour / 24 + iMin / 24 / 60), 0)
    Cells(i, "C") = TimeInDays
  Next
 End With
End Sub

Цитата
выделить все ячейки, которые будут содержать значения, включающие от 1 до 3 дней.
Это уж вы сами
Создание паттерна для извлечения времени ЧЧ:ММ через регулярные выражения RegExp
 
Цитата
А конструкция [^\:] не подойдёт?
Так попробуйте.
Цитата
что значит знак $ в замене? "$1:00", "$1:$3"
$1- первая скобочная группа - ([0-1][0-9]|[2][0-3])
$3 - третья группа - ([0-5][0-9])
Создание паттерна для извлечения времени ЧЧ:ММ через регулярные выражения RegExp
 
Цитата
все ниже меняем на 12:00
12
12,00
12*00
12-00
12/00
12+00
Код
Function iTime(cell$)
Dim mo As Object
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "([0-1][0-9]|[2][0-3])([,|/|\-|\.|\*|\+])?([0-5][0-9])?"
   If .test(cell) Then
   Set mo = .Execute(cell)
     If mo.Count = 1 Then
       iTime = .Replace(cell, "$1:00")
     Else
       iTime = .Replace(cell, "$1:$3")
     End If
   Else
     iTime = ""
   End If
 End With
End Function
Как из ячейки с цифрами, буквами и знаками препинания получить только цифры
 
UDF
Код
Function iDigit(cell As String) As Long
  iDigit = Int(Val(cell))
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 254 След.
Наверх