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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 241 След.
Миллион с буквой в миллион цифрами
 
UDF
Код
Function iEvro(cell$)
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d+\.\d+"
   iEvro = .Execute(cell)(0)
   iEvro = Replace(iEvro, ".", ",") * 1000000
 End With
End Function
Подтягивание данных из другого файла
 
В этой строке надо заменить
Код
Set MV = Worksheets("маты").Columns(1).Find(Target.Value2, , , xlWhole)

на
Код
Set MV = Worksheets("новый файл.xlsx").Worksheets(1).Columns(1).Find(Target.Value2, , , xlWhole)
Изменено: Kuzmich - 3 Июл 2020 11:21:04
Автоматический перенос данных с ценой >0 из одной таблицы в другую
 
Фильтр по цене >0
Поиск в массиве по двум критериям и вывод нескольких текстовых значений из одной ячейки
 
Цитата
в колонке O должны выводится все методы (без повторений, которые были использованы в данном месяце определенным заказчиком)
Код
Sub PoiskInMassiv()
Dim i As Long
Dim iLastRow As Long
Dim dict As Object
Dim FoundCustomer As Range
Dim FoundMetod As Range
Dim FAdr As String
Dim arr
 iLastRow = Cells(Rows.Count, "O").End(xlUp).Row + 2
   Range("M3:R" & iLastRow).ClearContents
   Set FoundCustomer = Columns("E").Find(Cells(2, "N"), , xlValues, xlWhole)
  If Not FoundCustomer Is Nothing Then
    Set dict = CreateObject("Scripting.Dictionary")
     FAdr = FoundCustomer.Address
     Do
       If Format(FoundCustomer.Offset(, -3), "MMMM") = Range("M2") Then
         arr = Split(FoundCustomer.Offset(, 5), ", ")
         For i = 0 To UBound(arr)
          dict.Item(arr(i)) = dict.Item(arr(i)) + FoundCustomer.Offset(, 2)
         Next
       End If
        Set FoundCustomer = Columns("E").FindNext(FoundCustomer)
     Loop While FoundCustomer.Address <> FAdr
        Range("O3").Resize(dict.Count, 2) = Application.Transpose(Array(dict.Keys, dict.Items))
       For i = 3 To 2 + dict.Count
         Set FoundMetod = Columns("T").Find(Cells(i, "O"), , xlValues, xlWhole)
         Cells(i, "Q") = Cells(i, "P") * FoundMetod.Offset(, 1)
       Next
         Range("R3") = WorksheetFunction.Sum(Range("Q3:Q" & 2 + dict.Count))
  End If
End Sub
Возвращать значение в столбец "Цена" в соответствии с "Кодом" и "Периодом"
 
Цитата
возвращать значение в столбец "Цена" в соответствии с "Кодом" и "Периодом" (нужен апр.20).
Код
'запускать при активном листе расчет
Sub Tsena()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FoundData As Range
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("G3:G" & iLastRow).ClearContents
 With Worksheets("данные")
  For i = 3 To iLastRow
    Set FoundCell = .Columns(3).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Set FoundData = .Columns(7).Find(What:=Cells(i, "I"), After:=FoundCell.Offset(, 4), _
           LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
       Cells(i, "G") = FoundData.Offset(, 1)
     End If
  Next
 End With
End Sub
Извлечь из текста числа: возраст (2 значное) и номер телефона (11 значное)
 
Если будет 33 года, то можно
Код
.Pattern = "\d{2}(?=\sлет|\sгод)"
Извлечь из текста числа: возраст (2 значное) и номер телефона (11 значное)
 
Цитата
иногда будет просто цифра, всегда в промежутке с 17 по 35
Замените
Код
    .Pattern = "\b\d{2}\b"
Изменено: Kuzmich - 28 Июн 2020 17:35:35
Извлечь из текста числа: возраст (2 значное) и номер телефона (11 значное)
 
UDF
Код
Function iNomer(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d{11}"
     If .test(cell) Then
       iNomer = .Execute(cell)(0)
     End If
 End With
End Function
Function iAge(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d{1,2}(?=\sлет)"
     If .test(cell) Then
       iAge = .Execute(cell)(0)
     End If
 End With
End Function
Развернуть числа ОТ и ДО. Вывести название диапазона рядом
 
Цитата
Но он не выводит названия из столбца C.
Код
Sub GRW()
Dim i As Range, j&, k&
ReDim v(1 To 65000, 1 To 2)
For Each i In [A:A].SpecialCells(xlCellTypeConstants, xlNumbers)
   For j = i To i(, 2)
       k = k + 1
       v(k, 1) = j
       v(k, 2) = i(, 3)
   Next
Next
[E1:F65000].Value = v
End Sub
VLOOKUP не возвращает в ячейку результат, если ищем по числу (но возвращает, если в ячейке содержатся не только цифры)
 
Попробуйте при активном листе raw
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, 1).NumberFormat = "@"
    Cells(i, 1) = Cells(i, 1).Text
  Next
End Sub
VLOOKUP не возвращает в ячейку результат, если ищем по числу (но возвращает, если в ячейке содержатся не только цифры)
 
На листе raw в ячейке А4 сделайте текстовый формат, чтобы в левом углу появился зеленый треугольник
Изменено: Kuzmich - 25 Июн 2020 18:05:20
Регулярные выражения, вхождение всех подстрок в строку
 
bananabrain,
Для вашего примера
Код
Sub iNomer()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim j As Integer
   Range("B1:C2").ClearContents
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "\d{5}"
  For i = 1 To 2
     If .test(Cells(i, "A")) Then
       Set mo = .Execute(Cells(i, "A"))
           j = 2
         For n = 0 To mo.Count - 1
           Cells(i, j) = Val(mo(n))
           j = j + 1
         Next
    End If
   Next
 End With
End Sub
VLOOKUP не возвращает в ячейку результат, если ищем по числу (но возвращает, если в ячейке содержатся не только цифры)
 
Сделайте текстовый формат
Подтягивание данных из другого файла
 
Цитата
что не так?
Код
Set MV = Workbooks("матывсе.xlsx").WorkSheets(1)
Регулярные выражения, вхождение всех подстрок в строку
 
RegExpExtract = matches.Item(1) даст второе значение
А вообще надо делать цикл по matches
Сравнение столбцов с подстановкой порядкового номера.
 
Код
Sub FindDublInTable()
Dim i As Long
Dim iLastRow As Long
Dim cell As Range
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
 Range("D1:D" & iLastRow).ClearContents
    For i = 1 To iLastRow
       If Cells(i, "C") <> "" Then
        Set cell = Range("B1:B7").Find(Cells(i, "C"), , xlValues, xlWhole)
        If Not cell Is Nothing Then
          Cells(i, "D") = "строка: " & cell.Row
        End If
       End If
    Next
End Sub
Power Query. Извлечение из комметариев назваие контрагента
 
Цитата
Возможно есть какое-то решение?
У кого нет PQ
UDF
Код
Function iOOO(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "(ООО|ТОВ)\s([А-ЯЁ]+)(?=\s\d)"
     iOOO = .Execute(cell)(0).SubMatches(1)
 End With
End Function
Преобразовать список номеров телефонов в вид 79999999999
 
с 9-ти значным номером решайте сами
Попробуйте такой код с выделенным диапазоном
Код
Sub iPhone()
 Dim re As Object
 Dim tempPhone As String
 Dim arr
 Dim cell As Range
 Dim RgxPhone As String
  Set arr = Selection
  Selection.Interior.ColorIndex = xlNone
  For Each cell In arr
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(-|\s|\+|\(|\))"
    re.Global = True
    re.IgnoreCase = True
    tempPhone = re.Replace(cell, "")
    re.Pattern = "(8|7)+(\d{3})+(\d{7})"
    RgxPhone = re.Replace(tempPhone, "$2$3")
    If Len(RgxPhone) > 10 Then
     cell.Interior.ColorIndex = 6:
    Else
      If Len(RgxPhone) = 10 Then
        cell = "7" & RgxPhone
      Else
        If Len(RgxPhone) = 7 Then
          Select Case Left(RgxPhone, 3)
          Case "320", "349"
            cell = "495" & RgxPhone
          Case "348", "356", "357"
            cell = "499" & RgxPhone
           End Select
        End If
      End If
    End If
  Next
End Sub

Ячейки с неправильными номерами подсвечены
Преобразовать список номеров телефонов в вид 79999999999
 
Цитата
Да, действительно, извиняюсь, не внимательно посмотрел.
Тогда "499"
Что делать с 9-ти значным номером?
Преобразовать список номеров телефонов в вид 79999999999
 
А номер 905799439 как преобразовывать?
Часть ячеек имеет числовой формат с разделителем группы разрядов. Зачем?
Номер 3492928 какой будет код?
Преобразовать список номеров телефонов в вид 79999999999
 
Цитата
притягивалось либо "499", либо "495".
Какой критерий?
Преобразовать список номеров телефонов в вид 79999999999
 
Цитата
свой код города
Это всегда 499 ?
Создать таблицу из таблицы комплектующих
 
А что мешает построить сводную таблицу?
Изменение формата даты из ДД.ММ.ГГГГ ЧЧ:ММ:СС на [$-ru-RU]d mmm yy;@
 
Цитата
"02.06.2015 09:02:21" должно превратиться в формат "2 июн 2015"
Код
Sub iData()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    Cells(i, "C") = CDate(Split(Cells(i, "B"), " ")(0))
    Cells(i, "C").NumberFormat = "[$-419]d mmm yyyy;@"
  Next
End Sub

Результат в столбце С
Удаление дублей, пропуская пустые значения, Инструментом "удаление дубликатов" не получается, не понятно почему
 
Цитата
Есть ли может быть какой-то макрос на эту тему?
Код
Sub DelDublTelefon()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim dict As Object
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set dict = CreateObject("Scripting.Dictionary")
  For i = 2 To iLastRow
    For j = 2 To 5
      If Cells(i, j) <> "" Then
       If Not dict.exists(CStr(Cells(i, j))) Then    'если нет номера, то добавляем его в словарь
         dict.Add CStr(Cells(i, j)), 1
       Else
         Cells(i, j) = ""
       End If
      End If
    Next
  Next
    Columns("H").ClearContents
    Cells(1, "H").Resize(dict.Count) = Application.Transpose(dict.Keys)
End Sub

В столбце Н список уникальных номеров.
Разделить на ячейки: извлечь из текстовой строки два символа с шагом четыре символа
 
Я формулой не умею
Код
Sub iRazdel()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim arr
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("F1:P" & iLastRow).ClearContents
    For i = 1 To iLastRow
      arr = Split(Cells(i, 1), ",")
      For j = 0 To UBound(arr)
          Cells(i, 6 + j) = arr(j)
      Next
    Next
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("E2:E" & iLastRow).ClearContents
    For i = 2 To iLastRow
      For j = 1 To 4
        If Cells(i, j) <> "" Then
          Cells(i, "E") = Cells(i, "E") & Cells(i, j) & ","
        End If
      Next
       If Cells(i, "E") <> "" Then
          Cells(i, "E") = Left(Cells(i, "E"), Len(Cells(i, "E")) - 1)
       End If
    Next
End Sub

Вывести все названия месяцев из заданного периода
 
Цитата
кто-то из них кровать
Ну, если кто-то, то это имя девушки
Поиск совпадений по нечетким данным: найти одинаковые адреса и обозначить их
 
Цитата
Ленина, Шумилова, Кирова и Волгодонская
  Я как раз об этом и говорил
им В.И.Ленина ул. и Ленина ул.
им генерала Шумилова ул. и ул.Шумилова
им Кирова ул и ул.Кирова
для программы это разные улицы
  если владение считать домом, то
Волгоград г., Волгодонская ул., владение 3 и
г.Волгоград ул.Волгодонская, 3 можно считать как один адрес
Поиск совпадений по нечетким данным: найти одинаковые адреса и обозначить их
 
Цитата
и все равно есть вероятность ошибок
Ну от ошибок никто не застрахован
Предлагаю такой алгоритм.
Из ячеек столбца Н выделяете в отдельные ячейки город, улицу и номер квартиры
Затем цикл по ячейкам столбца Н
ищем город из ячейки столбца Н в столбце С
затем сравниваем улицу и номер квартиры,
при совпадении трех условий пишем сообщение: в какой строке столбца С было совпадение
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 241 След.
Наверх