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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 242 След.
Преобразовать дату из ДД.ММ.ГГГГ в ГГГГ.ММ.ДД
 
Код
Просто потом оказывается, то у ТС дата в типа такого: "Начато 31.08.2020"

UDF
Код
Function iDate(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "(\d{1,2})\.(\d{1,2})\.(\d{2,4})"
     If .Test(cell) Then
       iDate = .Replace(cell, "$3.$2.$1.")
     Else
       iDate = ""
     End If
 End With
End Function
Из текста ячейки разнести характекристики в разные ячейки
 
Цитата
выделяем знаки до скобки и отнимаем на лево текст от скобки до первого пробела
UDF
Код
Function BeforeSkobki(cell As String) As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "[а-я\./-]+\s(?=\()"
     If .test(cell) Then
       BeforeSkobki = .Execute(cell)(0)
     End If
 End With
End Function

Function iSkobki(cell As String) As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "\((.+?)\)"
     If .test(cell) Then
       iSkobki = .Execute(cell)(0).Submatches(0)
     End If
 End With
End Function

Function Tkan(cell As String) As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "[а-я\./-]+\s(?=\()"
     If .test(cell) Then
       Tkan = Left(cell, .Execute(cell)(0).FirstIndex)
     End If
 End With
End Function

Function iWidth(cell As String) As Integer
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d+(?=см)"
     If .test(cell) Then
       iWidth = .Execute(cell)(0)
     End If
 End With
End Function
Если ячейка содержит кавычки, то...
 
Цитата
Оказывается часть кавычек такие "", а часть такие «», как в таком случае быть?
UDF
Код
Function iKav(cell$)
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "[""|««](.+)[""|»»]"
   If .test(cell) Then
     iKav = "ДА"
   Else
     iKav = "НЕТ"
   End If
 End With
End Function
Поиск по приблизительному текстовому значению
 
Никита Савин,
А почему написание улиц разное?
На листе1 вулиця Коперника
на листе2 Коперніка
VBA Извлечь даты из комментария к ячейке
 
Цитата
Однако с комментарием "начало: 05.09.2020 окончание: 06.09.2020" выдает ошибку.
Код
Function GetComment(rCell As Range) As String
Dim t As String
Dim e1 As Object
Dim e2 As Object
    t = rCell.Comment.Text
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "начало: \d+\.\d+\.(\d+)?"
        Set e1 = .Execute(t)
        .Pattern = "окончание: \d+\.\d+\.(\d+)?"
        Set e2 = .Execute(t)
       GetComment = e1(0) & " " & e2(0)
    End With
End Function
как отделить цифру из столбца с текстом, Подскажите формулу для отделения определенной цифры от текста
 
UDF
Код
Function Result(cell$) As Double
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d(?=х\d)"
     Result = .Execute(cell)(0)
 End With
End Function
Вывод последнего введенного значения из таблицы
 
Код
Sub LastKlas()
Dim Klas As Range
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundKlas As Range
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  iLR = Range("A1").End(xlDown).Row
  Range("B14:B" & iLastRow).ClearContents
  For i = 14 To iLastRow
    Set FoundKlas = Range("A1:A" & iLR).Find(Cells(i, "A"), , xlValues, xlWhole, xlByRows, xlPrevious)
    Cells(i, "B") = FoundKlas.Offset(, 2)
  Next
End Sub
Как выделить шрифт текста красным цветом по шаблону/маске?
 
Цитата
необходимо в тексте выделить все совпадения по маске
Период не рассматривал. Результат в столбце D
Код
Sub iDidgits()
Dim mo As Object
Dim n As Integer
Dim i As Long
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .MultiLine = True
   .Pattern = "(\d )?\d+(,\d+)?(?= м3| тонн| машин| ТС)"
  For i = 2 To 19
     If .test(Cells(i, 1)) Then
         Cells(i, 1).Copy Cells(i, 4)
       Set mo = .Execute(Cells(i, 1))
         For n = 0 To mo.Count - 1
           Cells(i, 4).Characters(mo(n).FirstIndex + 1, mo(n).Length).Font.ColorIndex = 3
         Next
    End If
   Next
 End With
End Sub
Извлечение из текста числа, а также преобразование даты из формата ДД.ММ.ГГ ВРЕМЯ в формат ДД.ММ.ГГ
 
Цитата
вытащить это число 5,6
UDF
Код
Function KiloGramm(cell$) As Double
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "\d+,\d+ ?(?=кг)"
     KiloGramm = .Execute(cell)(0)
 End With
End Function
Изменено: Kuzmich - 8 авг 2020 13:56:28
Удаление текста между "(" и ")", как удалить любое значение между скобками
 
Цитата
как удалить значение со скобками
UDF
Код
Function iSkobki(cell As String) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "\(.+?\)"
     If .test(cell) Then
       iSkobki = .Replace(cell, "")
     End If
 End With
End Function
Как напечатать шапку и одну n-ю строку из файла на одном листе?
 
gogy913, написал
Цитата
Думаю проще  через макрос.
А в чем проблема? Создайте лист Печать с требуемой шапкой и в цикле переносите
строку с нужного листа и печатайте. Формат листа Альбомный, подгоните поля и шрифт,
чтобы строка полностью умещалась по ширине листа. Удачи!
Получить из текста только название улицы
 
UDF
Код
Function iStreet(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "(ул.|пер.|пл.|б-р) ([А-ЯЁ]+)"
     iStreet = .Execute(cell)(0).SubMatches(1)
 End With
End Function
Перенос данных с карт в табличку
 
При активном листе Таблиця, макрос в стандартный модуль
Код
Sub FindЗагальна()
Dim FoundCell As Range
Dim FAdr As String
Dim tbl As ListObject
Dim n As Long
  With Worksheets("Карти")
    'удаление умной таблицы, кроме первой строки
    Set tbl = ActiveSheet.ListObjects("Таблица2")
       With tbl.DataBodyRange
        If .Rows.Count > 1 Then
          .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End If
       End With
       'очистка данных первой строки
       tbl.DataBodyRange.Rows(1).ClearContents
     Set FoundCell = .Columns("A:R").Find("Загальна інформація", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address     'нашли первое вхождение
       n = 1
       Do
         tbl.ListRows.Add 'для 2003 AlwaysInsert:=True    'добавляем строку в таблицу
         tbl.DataBodyRange(n, 1) = n
         tbl.DataBodyRange(n, 2) = .Cells(FoundCell.Row + 1, "C")     'П.І.Б.:
            'все остальные строки добавьте сами
         tbl.DataBodyRange(n, 32) = .Cells(FoundCell.Row + 37, "N")     '
         Set FoundCell = .Columns("A:R").FindNext(FoundCell)
         n = n + 1
       Loop While FoundCell.Address <> FAdr
     End If
  End With
End Sub
Перенос данных с карт в табличку
 
Цитата
не могу понять как скопировать данные новой карты в следующую строку
На листе Карти ищите все строки с Загальна інформація и относительно этой строки  переносите в умную Таблицу значения
Код
Sub FindЗагальна()
Dim FoundCell As Range
Dim FAdr As String
  With Worksheets("Карти")
     Set FoundCell = .Columns("A:R").Find("Загальна інформація", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address     'нашли первое вхождение
       Do
         'относительно строки с FoundCell.Address переносите в умную Таблицу значения
         'cells(FoundCell.Row+1,"C") - это П.І.Б.:
         'и т.д.
         Set FoundCell = .Columns("A:R").FindNext(FoundCell)
       Loop While FoundCell.Address <> FAdr
     End If
  End With
End Sub

Про умные таблицы почитайте
https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables
Перенос данных из строк в столбец
 
Код
Sub Perenos()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  iLR = Cells(Rows.Count, "M").End(xlUp).Row + 1
    Range("M2:M" & iLR).ClearContents
  For i = 2 To iLastRow
      iLR = Cells(Rows.Count, "M").End(xlUp).Row + 1
    Range(Cells(i, "A"), Cells(i, "I")).Copy
    Cells(iLR, "M").PasteSpecial Transpose:=True
  Next
  Application.CutCopyMode = False
End Sub
Вытянуть из описания в ячейке марку и модел техники
 
Ну, возможно, это я не так понял
Вытянуть из описания в ячейке марку и модел техники
 
buchlotnik,
после 34 строки есть
номер рами
об'єм:
потужність
Вытянуть из описания в ячейке марку и модел техники
 
buchlotnik,
А номер рамы где?
Для модели можно UDF на базе вашей функции
Код
Function iModel(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "Модель(\s|:)([^,.;]+)"
     iModel = .Execute(cell)(0).SubMatches(1)
 End With
End Function
Ввод значений массива для расчета, Не работает цикл создания одномерного массива
 
New, написал
Цитата
у вас r тут тип Variant, а вот а - имеет тип Integer.
Поясните, что не так?
Ввод значений массива для расчета, Не работает цикл создания одномерного массива
 
Цитата
где можно найти ошибку.
Код
Sub C_k()
    Dim ine() As Currency 'массив для значений
    Dim r, a As Integer 'r - размерность массива, a - индекс номера элемента
    Sheets("input").Select
    r = Cells(Rows.Count, 1).End(xlUp).Row - 1 ' вычисление размерности массива
    ReDim ine(r, 1) 'задание размерности массива
    For a = 1 To r 'счетчик для массива
'        For b = 2 To r + 1 'счетчик для перебора внесенных элементов
            ine(a, 1) = Cells(a + 1, 1).Value 'присвоение значений элементов массива
'        Next b
    Next a
End Sub
VBA Цикл перебирает диапазон, копирует по одной ячейке и вставляет в конец другого диапазона в другом Workbook + 1 пустая строка, VBA, циклы, копирование, вставка, через строку
 
Запускать при открытом листе ААА, обе книги д.б. открыты
Код
Sub Perenos()
Dim i As Long
  With Workbooks("B.xlsx").Worksheets("BBB")
    For i = 2 To 4
      Cells(i, "C").Copy .Cells(2 * (i - 1) , "D")
    Next
  End With
End Sub
Изменено: Kuzmich - 26 июл 2020 12:14:55
удаление с конца строки до определенного символа
 
UDF
Код
Function iAdres(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = ".+дом \d+[А-Я]"
     iAdres = .Execute(cell)(0)
 End With
End Function
Транспонировать несколько столбцов разной высоты, Требуется транспонировать данные разной высоты
 
Цитата
желаемый результат
Исправил код под желаемый результат
Код
Sub iTransp1()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
Dim FoundCell As Range
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Range("C2:I" & iLastRow).ClearContents
  For Each Rng In Range("B3:B" & iLastRow).SpecialCells(2, 1).Areas
    For i = 1 To Rng.Count
      Set FoundCell = Rows(1).Find(Rng.Cells(i), , xlValues, xlWhole)
      Rng.Cells(0, FoundCell.Column - 1) = Rng.Cells(i)
    Next
  Next
End Sub
Цикличные зависимые ячейки в расчете процентов, Цикличность в расчете процентов
 
Если выбрать в А1 и А2 процентный формат и вводимое число <=1 ,
то макрос в модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A2")) Is Nothing Then
   Application.EnableEvents = False
    If Target.Address = "$A$1" Then
      Range("A2") = 1 - Range("A1")
    Else
      Range("A1") = 1 - Range("A2")
    End If
 End If
   Application.EnableEvents = True
End Sub
Из длинной строки текста извлечь все цвета
 
Людмила,
Цитата
намного проще стало работать с этими данными
Данные у вас всегда на английском языке?
В одной ячейке только один цвет может быть?
По каким признакам определяется материал?
Размеры у вас имеют два и три измерения?
UDF для цвета
Код
Function iColor(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\bTeal\b|\bBrown\b|\bBlue\b|\bPink\b|\bHolographic\b|\bGold\b|\bPurple\b"
     If .test(cell) Then
       iColor = .Execute(cell)(0)
     End If
 End With
End Function
Транспонировать несколько столбцов разной высоты, Требуется транспонировать данные разной высоты
 
Код
Sub iTransp()
Dim iLastRow As Long
Dim Rng As Range
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  For Each Rng In Range("B3:B" & iLastRow).SpecialCells(2, 1).Areas
    Rng.Cells(0, 2).Resize(, Rng.Count) = Application.Transpose(Rng)
  Next
End Sub
Проблема с копированием Range с фильтром на другой лист
 
Вениамин Ветлужских, написал
Цитата
Так гораздо понятнее и правильнее!
То, что для вас понятней, можно согласиться.
Но чем докажете, что он правильнее моего?
Проблема с копированием Range с фильтром на другой лист
 
При активном листе "Все вина"
Код
Sub test()
Application.CutCopyMode = False
Dim Country As String
Dim Rng As Range
Country = Application.InputBox("Введите страну", Type:=2)
  ActiveSheet.ShowAllData
    ActiveSheet.Range("$A$1:$P$676").AutoFilter Field:=10, Criteria1:=Country
    With ActiveSheet.AutoFilter.Range
      Set Rng = .SpecialCells(xlCellTypeVisible) 'с шапкой таблицы
    End With
    With Worksheets("temp")
      Rng.Copy
      .Range("A6").PasteSpecial
    End With
Application.CutCopyMode = False
End Sub
VBA. Перенос значений в столбце из первого листа по одной ячейке на новые листы.
 
Цитата
чтобы вставлялось в уже существующие листы?
Код
Sub Raznesti()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
    With Worksheets(CStr(Cells(i, 1)))
       .Range("A1") = Cells(i, "B")
    End With
  Next
End Sub
Вытащить часть текста из ячейки
 
Цитата
Необходимы дата,время у этого статуса.
UDF
Код
Function iData(cell$)
 With CreateObject("VBScript.RegExp")
 .MultiLine = True
     .Pattern = "(\d{2}\.\d{2}\.\d{4} \d{1,2}:\d{2}).+(?=Изменен статус заявки:\s?Выполнена)"
     If .test(cell) Then
       iData = .Execute(cell)(0).SubMatches(0)
     End If
 End With
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 242 След.
Наверх