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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 242 След.
Как выделить шрифт текста красным цветом по шаблону/маске?
 
Цитата
необходимо в тексте выделить все совпадения по маске
Период не рассматривал. Результат в столбце 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
Вставить 2-ва новых столбца через каждих 2-ва уже существующих с помощью макроса., Макросом
 
Цитата
Добавить после каждых 2-х столбцов новые столбцы с записями единички -1.
Код
Sub InsertColumns()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
 iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = iLastCol - 1 To 3 Step -2
    Columns(i).Resize(, 2).Insert
    Range(Cells(1, i), Cells(iLastRow, i + 1)) = 1
  Next
End Sub
Как сделать, чтобы автоматом менялся диапазон суммирования?
 
Цитата
найти сумму по участкам
Код
Sub iSum()
Dim iLastRow As Long
Dim Rng As Range
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     For Each Rng In Range("A3:A" & iLastRow).SpecialCells(2, 1).Areas
       Rng.Cells(Rng.Count + 1, 2) = WorksheetFunction.Sum(Rng.Offset(, 1))
     Next
End Sub
Извлечь первые 4 цифры, идущие подряд в ячейке (год), Извлечь первые 4 цифры, идущие подряд в ячейке (год)
 
Цитата
и макрос можно.
UDF
Код
Function iYear(cell As String)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d{4}"
     If .Test(cell) Then
       iYear = .Execute(cell)(0)
     Else
       iYear = "данные уточняются"
     End If
 End With
End Function
Перенос даных из формы в следующую пустую строку
 
В коде должно быть
Код
If Range("B16") = "Н" Then

и при определении первой пустой ячейки у вас получается  FreeRow=503.
Думаю, что вам не это надо. Почитайте про умные таблицы
https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables
Вытащить значения из таблицы в формате pdf
 
PDF-Transformer-12.0.104 конвертируйте в xls
Поиск всех значений в диапазоне по заданному значению.
 
jocke2, написал
Цитата
а мой 2010-й эксель слишком старый даже для "постарше"
Что уж говорить о моем 2003.
Код
Sub Fruit()
Dim i As Long
Dim iLastRow As Long
Dim FoundFruit As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
 Range("E2:E" & iLastRow).ClearContents
 Range("E2:E" & iLastRow).NumberFormat = "@"
      For i = 2 To iLastRow
        Set FoundFruit = Columns(2).Find(Cells(i, "D"), , xlValues, xlWhole)
            FAdr = FoundFruit.Address
          Do
            Cells(i, "E") = Cells(i, "E") + Cells(FoundFruit.Row, "A") & ", "
            Set FoundFruit = Columns(2).FindNext(FoundFruit)
          Loop While FoundFruit.Address <> FAdr
             Cells(i, "E") = Left(Cells(i, "E"), Len(Cells(i, "E")) - 2)
      Next
End Sub
Миллион с буквой в миллион цифрами
 
UDF
Код
Function iEvro(cell$)
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d+\.\d+"
   iEvro = .Execute(cell)(0)
   iEvro = Replace(iEvro, ".", ",") * 1000000
 End With
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 242 След.
Наверх