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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 256 След.
Удаление только слов из ячейки
 
Сергійко Сергійко,
Я такого не писал, о чем вы упомянули в сообщении #15
Возможно вам нужно это
Код
Sub iWordDel()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With CreateObject("VBScript.RegExp")
     .Global = True
     .MultiLine = True
     .Pattern = "\s[A-Z]+$"
   For i = 2 To iLastRow
    Cells(i, "B") = .Replace(Cells(i, "A"), "")
   Next
 End With
End Sub
Удаление только слов из ячейки
 
UDF
Код
Function iWordDel(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\s[A-Z]+$"
   If .test(cell) Then
     iWordDel = .Replace(cell, "")
   End If
 End With
End Function
Изменено: Kuzmich - 6 май 2021 15:40:32
Выбор из выпадающего списка с подстановкой данных из справочника в другом месте
 
Если убрать объединенные ячейки и сделать выпадающий список в D15, то макрос в модуль листа Направление.
Срабатывает при выборе профессии из выпадающего списка.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("D15")) Is Nothing Then
 Dim FoundProf As Range
 Dim n As Integer
   Application.EnableEvents = False
  Range("A24:F27").ClearContents
  With Worksheets("Справочник")
    Set FoundProf = .Columns(1).Find(Target, , xlValues, xlWhole)
    If Not FoundProf Is Nothing Then
      n = FoundProf.MergeArea.Count
      .Range("B" & FoundProf.Row & ":B" & FoundProf.Row + n - 1).Copy Range("A24").Resize(n)
      .Range("C" & FoundProf.Row & ":C" & FoundProf.Row + n - 1).Copy Range("C24").Resize(n)
    End If
  End With
 End If
   Application.EnableEvents = True
End Sub
Выбор из выпадающего списка с подстановкой данных из справочника в другом месте
 
Антон Тетерев,
А зачем на листе Направление столько объединенных ячеек?
Без них никак?
Выбор из выпадающего списка с подстановкой данных из справочника в другом месте
 
Цитата
В строке Профессия есть выпадающий список,
В примере не нашел
Извлечение из ячейки части текста, возможно ли решить данную задачу формулой
 
UDF не подойдет?
Код
Function iPeriod(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d+\s?(мес\.|час|год)"
   If .test(cell) Then
     iPeriod = .Execute(cell)(0)
   Else
     iPeriod = ""
   End If
 End With
End Function
Сквозной поиск и подсветка дубликатов в книге, Прошу помощи в автомализиции поиска повторяющихся артикулов
 
Цитата
чтобы пользователь сам определял область поиска или название столбца, в котором программа будет искать
  Я бы добавил в макрос проверку наличия листа Дубликаты, если вы при каждом запуске макроса создаете такой лист.
Также нужна проверка наличия заголовка (Артикул или Номенклатура) на очередном листе и выдача сообщения об отсутствии оного,
так как столбцы с артикулами у вас предполагаются на каждом листе, а вот заголовки на некоторых листах отсутствовали.
Цитата
Application.InputBox("Укажите название столбца", , , , , , , 2)
Тогда
Код
Dim Col As String
Сквозной поиск и подсветка дубликатов в книге, Прошу помощи в автомализиции поиска повторяющихся артикулов
 
San Tut,
Что вы вводите этой строкой и что это за переменная?
Код
Dim Col As Мфкшфте
Set Col = Application.InputBox("Укажите название столбца", , , , , , , 2)
Вывод значения ячейки относительно выбранной с помощью макроса
 
Цитата
на первом листе условно есть ячейка с формулой ссылающейся на ячейку B3 на втором листе
Пусть это будет ячейка А1
Код
Sub ww()
Range("A1").Formula = Split(Range("A1").Formula, "!")(0) & "!B" & Mid(Split(Range("A1").Formula, "!")(1), 2) + 1
End Sub

Запуская макрос получите
Цитата
нажатием макроса заставить ее ссылаться на  одну ячейку ниже  на втором листе(  B4)
Сквозной поиск и подсветка дубликатов в книге, Прошу помощи в автомализиции поиска повторяющихся артикулов
 
San Tut, написал
Цитата
а у меня получилось 935
Если вы на всех листах в строке 1 напишите слово Артикул, там где у вас действительно артикулы,
то тогда и меня получилось 935

Цитата
за исключением жестко прописанного диапазона, который я хотел бы заменить на переменную
В стандартный модуль, запускать при активном листе Дубликаты
Код
Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
   Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
  For Each Sht In Worksheets
    If Sht.Name <> "Дубликаты" Then
      With Sht
       Set FoundCell = .Rows(1).Find("Артикул", , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          ColArticul = FoundCell.Column
          iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
          arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
          For i = 1 To UBound(arr)
            dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
          Next
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
   Columns("C:D").ClearContents
   Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub
Удаление повторов внутри ячейки, учитывая условия
 
Результат в столбец Н
Код
Sub iConcatenate()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("H2:H" & iLastRow).ClearContents
  For i = 2 To iLastRow
     Cells(i, 8) = Cells(i, 1)
    For j = 1 To 4
     If Cells(i, j + 1) <> "" Then
      If Split(Cells(i, j), " ")(0) = Split(Cells(i, j + 1), " ")(0) Then
        Cells(i, 8) = Cells(i, 8) & " ; " & Split(Cells(i, j + 1), " ", 2)(1)
      Else
        Cells(i, 8) = Cells(i, 8) & "; " & Cells(i, j + 1)
      End If
     End If
    Next
 Next
End Sub
Как из таблицы на 3 столбца перенести данные в один столбец
 
Цитата
Надо получить столбец D с цифрами от 1 до 60
В столбец, отстоящий на два столбца от массива
Код
Sub OneColumn()
Dim arr
Dim arr1
Dim i As Long
Dim j As Long
  arr = Range("A1").CurrentRegion.Value
  ReDim arr1(1 To UBound(arr) * UBound(arr, 2), 1 To 1)
  For j = 1 To UBound(arr, 2)
    For i = 1 To UBound(arr)
      arr1(i + (j - 1) * UBound(arr), 1) = arr(i, j)
    Next
  Next
  Cells(1, UBound(arr, 2) + 2).Resize(UBound(arr) * UBound(arr, 2)) = arr1
End Sub
Автоматическая выборка уникальных значений
 
Цитата
Можете подсказать готовое решение (макрос, например)?
Код
Sub test()
Dim arr
Dim arr1
Dim dic As Object
Dim i As Long
Dim j As Long
Dim iLastRow As Long
Dim iWord As String
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("B1:B" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("A1:A" & iLastRow).Value
  For i = 1 To UBound(arr)
    arr1 = Split(arr(i, 1), " ")
    For j = 0 To UBound(arr1)
      dic.Item(arr1(j)) = dic.Item(arr1(j))
    Next j
  Next i
   Range("B1").Resize(dic.Count) = Application.Transpose(dic.keys)
   iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Range("B1:B" & iLastRow).Sort key1:=Range("B1"), Order1:=xlAscending
End Sub

Результат на листе Было в столбце В
Переноса слова из одной ячейки в другую
 
Цитата
вытащить наименование города
UDF
Код
Function iTown(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "г\.[^,]+"
   If .test(cell) Then
     iTown = .Execute(cell)(0)
   Else
     iTown = ""
   End If
 End With
End Function
Пронумеровать уникальные значения по условию
 
По двум столбцам
Код
Sub FioNomer()
Dim i As Long
Dim iLastRow As Long
Dim FAdr As String
Dim n As Integer
Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("E2:E" & iLastRow).ClearContents
     n = 1
     For i = 2 To iLastRow
        If Cells(i, "C") < 6 Or Cells(i, "D") < 6 Then
          If Not dic.Exists(CStr(Cells(i, "B"))) Then
            dic.Add CStr(Cells(i, "B")), 1
            Cells(i, "E") = n
             n = n + 1
          End If
        End If
    Next
End Sub
Пронумеровать уникальные значения по условию
 
snatg,
Так  почему не нумеруется строка номером 4
9 Григорьев   6   5   4
Пронумеровать уникальные значения по условию
 
Если вы используете условие ИЛИ(C2<6;D2<6),
то почему не нумеруется строка номером 4
9 Григорьев 6 5 4
Пронумеровать уникальные значения по условию
 
snatg,
Почему в строке
8 Курников 1 8
появился порядковый номер?
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
azma,
Массив городов в макросе берется с ячейки H2, а у вас слово Актау в ячейке H1
Код
Towns = Range("H2", Cells(Rows.Count, "H").End(xlUp)).Value
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
azma,
Так макрос работает без учета регистра
Код
re.IgnoreCase = True
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
azma,
Пробуйте
Код
Sub ColorTown()
Dim i As Long
Dim j As Integer
Dim iCell As Range
Dim re As Object
Dim oMatches As Object
Dim oMatch As Object
Dim Towns()
  Application.ScreenUpdating = False
  Towns = Range("H2", Cells(Rows.Count, "H").End(xlUp)).Value
  Columns("A").Font.Color = vbBlack
    Range("B2", Cells(Rows.Count, "B").End(xlUp)).Clear
  Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    re.IgnoreCase = True
    re.Pattern = Join(WorksheetFunction.Transpose(Towns), "|")
  For Each iCell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    Set oMatches = re.Execute(iCell)
      For j = 0 To oMatches.Count - 1
         Set oMatch = oMatches.Item(j)
         With iCell.Characters(Start:=oMatch.FirstIndex + 1, Length:=oMatch.Length).Font
           .Color = vbBlue
         End With
      Next
  Next
  Application.ScreenUpdating = True
End Sub
Пронумеровать уникальные значения по условию
 
snatg,
Скопируйте макрос в стандартный модуль и запустите
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
azma,
Устроит вас решение с подсветкой городов другим цветом  в ячейках столбца А ?
Пронумеровать уникальные значения по условию
 
Код
Sub FioNomer()
Dim i As Long
Dim iLastRow As Long
Dim FAdr As String
Dim n As Integer
Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("D2:D" & iLastRow).ClearContents
     n = 1
     For i = 2 To iLastRow
        If Cells(i, "C") < 6 Then
          If Not dic.Exists(CStr(Cells(i, "B"))) Then
            dic.Add CStr(Cells(i, "B")), 1
            Cells(i, "D") = n
             n = n + 1
          End If
        End If
    Next
End Sub
Поиск положения числа в двумерном массиве
 
При активном Лист2 запустить макрос
Код
Sub ChisloAdres()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("B1:B" & iLastRow).ClearContents
With Worksheets("Лист1")
  For i = 1 To iLastRow
    Set FoundCell = .Range("A1").CurrentRegion.Find(Cells(i, "A"), , xlFormulas, xlWhole)
     If Not FoundCell Is Nothing Then
       Cells(i, "B") = FoundCell.Address(0, 0)
     End If
  Next
End With
End Sub
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
Marat Ta, написал
Цитата
Если 2 города - выделил формулу зеленым фоном.
Я имел в виду, что если в ячейке встречается два города, то и выделять нужно два
Актау Фарм г.Актобе
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
Код
Dim K As Long
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
Цитата
задача макроса искать название города в А
А если в ячейке столбца А будет два города?
Поиск слов по маске без учета регистра и запись рядом соответствующего слова
 
Цитата
нужен макрос который мог поискать несколько слов в столбце А
И где эти несколько слов?
Сумма значений нескольких ячеек по условию, Суммировать значения из ячеек, если ячейка снизу и следующая за ней пустая
 
Цитата
как сосчитать значение в ячейке
Код
Sub iSumma()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
 Range("D2:D" & iLastRow).ClearContents
  For i = 2 To iLastRow
      Cells(i, "D") = 0
      n = 0
    If Cells(i + n + 1, "B") = Cells(i, "B") Then
      Do
         Cells(i, "D") = Cells(i, "D") + Cells(i + n, "F")
         n = n + 1
      Loop While Cells(i, "B") = Cells(i + n, "B")
         i = i + n - 1
    Else
       Cells(i, "D") = Cells(i, "F")
    End If
  Next
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 256 След.
Наверх