Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 259 След.
Поиск значений из ячейки в разных столбцах
 
Цитата
передать в комментарий данные
Код
Sub iAdres()
Dim FoundCell As Range
Dim ws1 As Worksheet
Dim j As Integer
Dim i As Integer
Dim j_cell
Dim msg As String
 Set ws1 = ThisWorkbook.Worksheets("Лист1")
     If Not Range("G4").SpecialCells(xlCellTypeComments) Is Nothing Then Range("G4").Comment.Delete
     If Not Range("H4").SpecialCells(xlCellTypeComments) Is Nothing Then Range("H4").Comment.Delete
     If Not Range("I4").SpecialCells(xlCellTypeComments) Is Nothing Then Range("I4").Comment.Delete
 With ws1
  For j = 7 To 9
    j_cell = Split(Cells(4, j), ", ")
    For i = 0 To UBound(j_cell)
      Set FoundCell = .Columns("A:J").Find(j_cell(i), , xlValues, xlWhole)
      msg = msg & FoundCell.Address(0, 0) & ", "
    Next
      Cells(4, j).AddComment.Text Text:=msg
      msg = ""
  Next
  End With
End Sub
Заменить первую цифру после буквы
 
Цитата
как макросом заменить первую цифру после буквы на нужную цифру
UDF замена на 2
Код
Function iDigit(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "([A-Z]{1,})(\d)"
   If .test(cell) Then
       iDigit = .Replace(cell, "$12")
   Else
     iDigit = ""
   End If
 End With
End Function
Поиск значений из ячейки в разных столбцах
 
Цитата
получить ссылки (адреса ячеек) этих табельных номеров
При активном листе Лист2 запустить макрос
адреса в строке 5
Код
Sub iAdres()
Dim FoundCell As Range
Dim ws1 As Worksheet
Dim j As Integer
Dim i As Integer
Dim j_cell
 Set ws1 = ThisWorkbook.Worksheets("Лист1")
   Rows(5).ClearContents
 With ws1
  For j = 7 To 9
    j_cell = Split(Cells(4, j), ", ")
    For i = 0 To UBound(j_cell)
      Set FoundCell = .Columns("A:J").Find(j_cell(i), , xlValues, xlWhole)
      Cells(5, j) = Cells(5, j) & FoundCell.Address(0, 0) & ", "
    Next
  Next
  End With
End Sub
Необходимо извлечь слово из ячейки, если такое слово есть в справочнике
 
Цитата
для извлечения улица из текста
для ул., пер., пл., б-р
UDF
Код
Function iStreet(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "([А-ЯЁ]+)(?=\s(ул.|пер.|пл.|б-р))"
     iStreet = .Execute(cell)(0)
 End With
Удалить строки до строки с определенным словом
 
Цитата
чтобы удалялись все строки до строки
Код
Sub горох()
Dim CHch As Range
Set CHch = Columns(1).Find("Ч.ч.", , xlValues, xlWhole)
    If Not CHch Is Nothing Then
'     Range("A1:L13").EntireRow.Delete
      Rows("1:" & CHch.Row - 1).Delete
    End If
End Sub
Вычленить из текста в разные столбцы декор, структуру и размеры
 
Виктория Кунавина,
UDF для вашего примера
Код
Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "[A-Z]\d{2,4}"
   If .test(cell) Then
     iDigits = .Execute(cell)(0)
   Else
     iDigits = ""
   End If
 End With
End Function
Function iSTDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "ST\d{1,2}"
   If .test(cell) Then
     iSTDigits = .Execute(cell)(0)
   Else
     iSTDigits = ""
   End If
 End With
End Function
Function iRazmer(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d+x\d+(,\d+)?"
   If .test(cell) Then
     iRazmer = .Execute(cell)(0)
   Else
     iRazmer = ""
   End If
 End With
End Function
удалить дублирующие строки, при условии, что они идут подряд
 
Цитата
Нужнно именно автоматизировать.
Адаптируйте для умной таблицы
Код
Sub DelRow()
Dim i As Long
Dim iLastRow As Long
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1
  For i = iLastRow To 2 Step -1
    If Cells(i - 1, "A") = Cells(i, "A") Then Rows(i).Delete
  Next
End Sub
Продолжение нумерации в столбце из 1-го таблицы на 2-ю, 3-ю...
 
Код
Sub iNumber()
Dim i As Long
Dim n As Long
Dim k As Long
Dim iLastRow As Long
Application.ScreenUpdating = False
  iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
      n = 1
  For i = 11 To iLastRow
      Cells(i, "B") = n
   If Not Cells(i, "B").MergeCells Then
    If Cells(i + 1, "C").Font.Bold <> True Then
         k = 1
        Do While Cells(i + 1, "C").Font.Bold <> True
          If i = iLastRow Then Exit Sub
           Cells(i + 1, "B").NumberFormat = "@"
           Cells(i + 1, "B") = n & "." & k
           i = i + 1
           k = k + 1
        Loop
     Else
     End If
       n = n + 1
    End If
  Next
Application.ScreenUpdating = True
End Sub
суммироваие по условиям включая дату
 
Макрос в стандартный модуль, запускать при активном листе Sheet1
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim List2 As Worksheet
Dim FoundCell As Range
Dim FAdr As String
   Set List2 = ThisWorkbook.Worksheets("Sheet2")
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("D2:D" & iLastRow) = 0
  With List2
    For i = 2 To iLastRow
      Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          FAdr = FoundCell.Address
          Do
            If FoundCell.Offset(, 1) >= Cells(i, "B") And FoundCell.Offset(, 1) <= Cells(i, "C") Then
              Cells(i, "D") = Cells(i, "D") + FoundCell.Offset(, 2)
            End If
            Set FoundCell = .Columns(1).FindNext(FoundCell)
          Loop While FoundCell.Address <> FAdr
        End If
    Next
  End With
End Sub
VBA. Определение конца столбца по условию
 
Цитата
нужен весь столбец данных до факта
Для примера из сообщения #5
Сумма по столбцу В
Код
Sub SummaPlanFact()
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim StrokaPlan As Long
Dim SummaPlan As Double
Dim SummaFact As Double
  StrokaPlan = Columns("A").Find("факт", , xlValues, xlWhole).Row
  SummaPlan = WorksheetFunction.Sum(Range("B1:B" & StrokaPlan - 2))
  SummaFact = WorksheetFunction.Sum(Range("B" & StrokaPlan & ":B" & iLastRow))
End Sub
Записать в столбец каждое значение из диапазона 00093682 – 00093685
 
Пусть в А1 00093682 – 00093685
в столбце В  все  значение от 00093682 до 00093685
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = 1
 Cells(iLastRow, "B") = Split(Cells(1, 1), " – ")(0)
  Do
   Cells(iLastRow, "B").NumberFormat = "00000000"
   Cells(iLastRow + 1, "B") = Cells(iLastRow, "B") + 1
  iLastRow = iLastRow + 1
  Loop While Format(Cells(iLastRow, "B"), "00000000") <> Split(Cells(1, 1), " – ")(1)
End Sub
Суммирование через интервал
 
Цитата
Нужно просуммировать каждую определенную выполняемую работу
Сумма в столбце J
Код
Sub iSumma()
Dim i As Long
Dim n As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
   Range("J10:J" & iLastRow).ClearContents
  For i = 11 To iLastRow
        n = i
      Do While Cells(i + 1, "B").Font.Bold <> True
          If i = iLastRow + 1 Then Exit Sub
          Cells(n, "J") = Cells(n, "J") + Cells(i + 1, "I")
          i = i + 1
      Loop
  Next
End Sub
Переход к дате на календаре макросом
 
Цитата
при вводе в ячейку "Е1" даты можно было быстро перейти к такой же дате на календаре в строке "J11:BR11".
В строке 9 продублируйте даты месяца в формате даты 14.03.2001
Код
Sub PoiskDate()
Dim iDate As Date
Dim FoundDate As Range
  iDate = Range("E1")
  Set FoundDate = Rows(9).Find(iDate, , xlValues, xlWhole)
  Cells(11, FoundDate.Column).Select
End Sub
Сортировка в алфавитном порядке внутри ячейки
 
Код
Sub iSortCell()
Dim iLastRow&
Dim arr, n&, i&, j&, Tmp
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For n = 1 To iLastRow
    arr = Application.Trim(Split(Cells(n, "A"), ";"))
    For i = LBound(arr) To UBound(arr) - 1
      For j = i + 1 To UBound(arr)
       If arr(i) > arr(j) Then Tmp = arr(j): arr(j) = arr(i): arr(i) = Tmp
      Next j
   Next i
     Cells(n, "B") = Join(arr, ";")
  Next
End Sub
Добавление строк с другого листа по условию
 
Цитата
Подскажите решение задачи)
Поставить фильтр и перенести видимые сроки на другой лист
Ввести данные из UserForm.TextBox в диапазон ячеек
 
Цитата
Ячейки работают,  не в ряд, а в столбик. Что делать ?
Код
Dim lOff&
For lOff = 1 to 6 Step 2 'цикл от 1 до 6 с шагом 2 (т.е. через одну)
    Cells(ActiveCell.Row, 1).Offset(,lOff-1).Value = TextBox1.Value
Next
Сортировка в алфавитном порядке внутри ячейки
 
Взяли данные из ячейки в массив, отсортировали, выгрузили опять в ячейку
Как заставить макрос выполнять указанное действие столько раз, сколько раз искомое слово встречается на листе
 
Неопытный_Экселист,
Цитата
For i = 1 To Rng
Тип i видимо Long
а Rng - Range
Без примера еще долго будем гадать
Как заставить макрос выполнять указанное действие столько раз, сколько раз искомое слово встречается на листе
 
Неопытный_Экселист,
А вы приведите пример
Как заставить макрос выполнять указанное действие столько раз, сколько раз искомое слово встречается на листе
 
Посмотрите справку по FindNext
Как заставить макрос выполнять указанное действие столько раз, сколько раз искомое слово встречается на листе
 
Цитата
Как заставить его обработать все нахождения указанного слова на листе?
Используйте FindNext
Преобразование текста 22 июня 2021 г. 12:06 в дату
 
UDF
Код
Function toDate(str As String) As Date
    toDate = CDate(Split(str, "г.")(0))
End Function
Вставить данные с одного листа на другой без копирования ниже последней заполненной строки
 
Код
 Лист1.Range("A2:E" & Лист1.Cells(Лист1.Rows.Count, 1).End(xlUp).Row).Copy _
 Лист2.Range("F" & Лист2.Cells(Лист2.Rows.Count, 6).End(xlUp).Row + 1)
Получить число из строки, записанной через разделители
 
UDF
Код
Function Result(cell As String)
  Result = Split(cell, "/")(UBound(Split(cell, "/")))
End Function
Поиск и замена значения по двум соответствующим ячейкам
 
Макрос в модуль Лист1, при изменении ячейки J4 срабатывает и меняет значение
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("J4")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundImja As Range
Dim FAdr As String
  Set FoundImja = Columns(1).Find(Range("G4"), , xlValues, xlWhole)
       If Not FoundImja Is Nothing Then
           FAdr = FoundImja.Address
         Do
           If FoundImja.Offset(, 1) = Range("H4") Then
              FoundImja.Offset(, 2) = Range("J4")
              Exit Do
           End If
           Set FoundImja = Columns(1).FindNext(FoundImja)
         Loop While FoundImja.Address <> FAdr
       End If
  End If
    Application.EnableEvents = True
End Sub
Подскажите, как можно в VBA использовать переменные в диапазоне функции Range ?
 
Yuri Kr [ Женщина ] создавая тему на другом форуме, информируйте об этом
http://www.excelworld.ru/forum/10-47757-1
Вытащить число в текстовой строке по признаку
 
UDF
Код
Function iMetr(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+(?=\s?(м|кв.м))"
   If .test(cell) Then
     iMetr = .Execute(cell)(0)
   Else
     iMetr = ""
   End If
 End With
End Function
Создать папку с именем ячейки, в эту папку сохранить открытую книгу
 
Роман, написал
Цитата
Как сделать что бы изменения в исходной книге сохранялись ?
Исходная книга - это ThisWorkbook
Код
ThisWorkbook.Close SaveChanges:=True
Создать папку с именем ячейки, в эту папку сохранить открытую книгу
 
Создавайте директорию в той папке, где находится ThisWorkbook
Код
Dim iPath As String
iPath = ThisWorkbook.Path & "\" & [A1].Value
   'если такой папки нет , то создаем ее
   If Dir(iPath, vbDirectory) = "" Then MkDir iPath
'создаете новую книгу, проделываете с ней манипуляции и сохраняете
ActiveWorkbook.SaveAs iPath  & "\" & [A1].Value & ".xls"
Изменено: Kuzmich - 19.06.2021 19:54:25
Регулярные выражения. Метасимволы. Поиск наиболее полного руководства
 
Фридл Дж. Регулярные выражения. Библиотека программиста.
Бен Форта Освой самостоятельно регулярные выражения (regexp).
Ян Гойвертс, Стивен Левитан Регулярные выражения. Сборник рецептов
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 259 След.
Наверх