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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 241 След.
Вставить 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
Подтягивание данных из другого файла
 
В этой строке надо заменить
Код
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

Результат в столбце С
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 241 След.
Наверх