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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 263 След.
Как посчитать сумму, когда в ячейках цифры и текст написаны вместе?
 
Код
Sub GetSumma()
Dim mo As Object
Dim n As Integer
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 = "\d+(,\d+)?$"
  For i = 1 To iLastRow
      Cells(i, 3) = 0
    If .Test(Cells(i, 1)) Then
      Set mo = .Execute(Cells(i, 1))
      For n = 0 To mo.Count - 1
        Cells(i, 3) = Cells(i, 3) + CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub

Результат в столбце С
Нужно чтобы консолидация суммировала только один столбец из нескольких
 
Цитата
просуммировала только кол-во
Код
Sub Marka()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
Dim iKey
    iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
     Range("H4:K" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("C4:F" & iLastRow).Value
  For i = 1 To UBound(arr)
    dic.Item(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = _
    dic.Item(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) + arr(i, 4)
  Next i
    i = 4
  For Each iKey In dic.keys
    Cells(i, "H") = Split(iKey, "|")(0)
    Cells(i, "I") = Split(iKey, "|")(1)
    Cells(i, "J") = Split(iKey, "|")(2)
    Cells(i, "K") = dic.Item(iKey)
    i = i + 1
  Next
End Sub
Как посчитать в табеле часы, когда в ячейках цифры и символы написаны вместе?
 
Код
Sub iSumma()
Dim j As Long
Dim iSumma As Double
  For j = 3 To 33 'от C до AG
    If IsNumeric(Cells(7, j)) Then
      iSumma = iSumma + Cells(7, j)
    Else
      If InStr(1, Cells(7, j), "/") > 0 Then
        iSumma = iSumma + Split(Cells(7, j), "/")(0)
          If IsNumeric(Split(Cells(7, j), "/")(1)) Then
            iSumma = iSumma + Split(Cells(7, j), "/")(1)
          End If
      End If
    End If
  Next
    Cells(7, "AH") = iSumma
End Sub
Как посчитать в табеле часы, когда в ячейках цифры и символы написаны вместе?
 
Цитата
суммировать с остальными.
у меня получилась сумма 179,5. правильно?
Перенос вертикально горизонтально расположенных данных (с различным числом строк)
 
MVMM, а зачем
Цитата
вручную можно было  определить область выгрузки
Добавьте в книгу Лист1
Код
Sub iChicken_1()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iLR As Long
Dim iLastRow As Long
 With Worksheets("Лист1")
   .Cells.Clear
   iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   iLR = Range("B1").End(xlDown).Row
   For i = 2 To iLR
     If Cells(i, "C") = "Курицы" Then
       n = 21
     Else
       n = 31
     End If
       For j = 6 To n Step 2
         .Cells(iLastRow, "A") = Cells(i, "A")
         .Cells(iLastRow, "B") = Cells(i, "C")
         .Cells(iLastRow, "C") = Cells(i, j)
         .Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
   Next
   .Range("A2:D" & iLastRow - 1).Borders.Weight = xlThin
   .Activate
 End With
End Sub
Изменено: Kuzmich - 12.01.2022 11:13:03
Перенос вертикально горизонтально расположенных данных (с различным числом строк)
 
Код
Sub iChicken()
Dim i As Long
Dim j As Long
Dim iLR As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
 iLR = Range("B1").End(xlDown).Row
   Range("A15:D" & iLastRow).ClearContents
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
   For i = 2 To iLR
     If Cells(i, "C") = "Курицы" Then
       For j = 6 To 21 Step 2
         Cells(iLastRow, "A") = Cells(i, "A")
         Cells(iLastRow, "B") = Cells(i, "C")
         Cells(iLastRow, "C") = Cells(i, j)
         Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
     Else
       For j = 6 To 31 Step 2
         Cells(iLastRow, "A") = Cells(i, "A")
         Cells(iLastRow, "B") = Cells(i, "C")
         Cells(iLastRow, "C") = Cells(i, j)
         Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
     End If
   Next
End Sub
Макрос сравнения двух списков на разных листах в одной книге
 
Вы сообщение 3 смотрели?
Где в вашем примере макрос?
Макрос сравнения двух списков на разных листах в одной книге
 
Код
Set Found = ws1.Range("B2:B" & ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row).Find(Numbers2(i, 1))

Замените русские В на латинские B
макрос удаления лишних строк из таблицы по условию
 
Учитесь дальше
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=121301
Есть там ссылка на мануал, изучите
Изменено: Kuzmich - 09.01.2022 14:06:27
Суммирование разного количества соседних ячеек ограниченных пустыми ячейками
 
Код
Sub iSumma()
Dim Rng As Range
    Range("G3:G" & Cells(Rows.Count, "D").End(xlUp).Row).Copy
    Range("G3").PasteSpecial xlPasteValues
  For Each Rng In Range("G3:G" & Cells(Rows.Count, "D").End(xlUp).Row).SpecialCells(2, 1).Areas
    Rng.Cells(0, 2) = WorksheetFunction.Sum(Rng) / Rng(0, -2)
    Rng.Cells(0, 2).NumberFormat = "#,##0.00"
  Next
End Sub
Перенос значений строки на другой лист при введение одного значения на другом листе
 
При активном листе Список запустить макрос
Код
Sub Perenos()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim n As Integer
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 With Worksheets("Заказ")
    iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
    .Range("A5:K" & iLR).ClearContents
    n = 1
  For i = 2 To iLastRow
      iLR = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    If Cells(i, "J") > 0 Then
      .Cells(iLR, "A") = n
      Cells(i, "J").Copy .Cells(iLR, "B")
      Range(Cells(i, "A"), Cells(i, "I")).Copy .Cells(iLR, "C")
      n = n + 1
    End If
  Next
    .Activate
 End With
  Application.CutCopyMode = False
End Sub
Изменено: Kuzmich - 07.01.2022 20:01:24
Регулярное выражение. Вытащить самое первое слово или выражение до первого пробела.
 
UDF
Код
Function iWord(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
  If InStr(1, cell, "Главное_Слово") > 0 Then
    iWord = "Главное_Слово"
  Else
     .Pattern = "^\W+\d+"
   If .test(cell) Then
     iWord = .Execute(cell)(0)
   Else
     iWord = ""
   End If
  End If
 End With
End Function
Регулярное выражение. Вытащить самое первое слово или выражение до первого пробела.
 
Цитата
необходимо вытащить самое первое слово или выражение до первого пробела
В вашем примере это будет "Слово, но не "Слово1
Ввод формулы макросом в плавающий диапазон
 
Код
Sub iFormula()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
  For i = 10 To iLastRow
    Cells(i, "F").Formula = "=D" & i & "*E" & i
  Next
  Cells(iLastRow + 1, "F").Formula = "=Sum(F10:F" & iLastRow & ")"
End Sub
Изменено: Kuzmich - 27.12.2021 11:27:17
Возможно ли как то сделать проверку даты, что если дата не ВС, записывать дату след. ВС ?, проверка даты и запись ближайшей нужной по дню недели
 
Цитата
в ячейке E10
Код
=ЕСЛИ(ДЕНЬНЕД(B10;2)=7;B10;B10+7-ДЕНЬНЕД(B10;2))
Извлечь число между символами "/" из адреса интернет-страницы
 
Код
Function iDigit(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\/(\d+)\/"
   If .test(cell) Then
       iDigit = CDbl(.Execute(cell)(0).SubMatches(0))
   Else
     iDigit = ""
   End If
 End With
End Function
Зеркалировать текст в ячеке
 
Код
Function iReverse(cell$)
  iReverse = StrReverse(cell)
End Function
Из текста ячейки извлечь текст при наличии определенного заголовка
 
UDF
Код
Sub GetFragment()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "[А-Я\s]+ В-СИБдо\d{1,2}\.\d{2} \d{2}:\d{2}"
  For i = 1 To iLastRow
    If .Test(Cells(i, 3)) Then
      Set mo = .Execute(Cells(i, 3))
      For n = 0 To mo.Count - 1
        Cells(i, n + 10) = mo(n)
      Next
    End If
  Next
End With
End Sub
Убрать домен из URL адреса
 
Код
Sub iDomen()
  Range("B1") = Split(Range("A1"), "/", 4)(3)
End Sub
Выборка ТОЛЬКО основных сотрудники категорий ВиП и РСП
 
Цитата
Необходимо, чтобы в графу К попадали ТОЛЬКО основные сотрудники категории ВиП и РСП, работающие в подразделениях 01.11 и 01.12 (со всеми подструктурными подразделениями)
Код
Sub Doctors()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "W").End(xlUp).Row
  For i = 10 To iLastRow
    If Cells(i, "W") Like "01.11*" Or Cells(i, "W") Like "01.12*" Then
      If Cells(i, "X") = "Основной" And Cells(i, "AC") = "ВиП" Or Cells(i, "AC") = "РСП" Then
        Cells(i, "K") = 1
      Else
        Cells(i, "K") = 0
      End If
    End If
  Next
End Sub
Массовое удаление текста строго между 6 и 7 слэшем.
 
Цитата
строго между 6 и 7 слэшем
Код
Sub GetSlesh6_7()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "[^/]+"
  For i = 1 To iLastRow
    If .Test(Cells(i, "A")) Then
      Set mo = .Execute(Cells(i, "A"))
      If mo.Count >= 7 Then
         Cells(i, "D") = Replace(Cells(i, "A"), mo(5) & "/", "")
      End If
    End If
  Next
End With
End Sub
Удаление текста до и после определенных слов, Удаление текста
 
Цитата
вытащить текст между /wa-data/ и .webp (включительно)
Код
Sub GetFragmentText()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "/wa-data/.+?webp"
  For i = 2 To iLastRow
    If .Test(Cells(i, 4)) Then
      Set mo = .Execute(Cells(i, 4))
      For n = 0 To mo.Count - 1
        Cells(i, n + 5) = CStr(mo(n))
      Next
    End If
  Next
End With
End Sub
При извлечении числа из текста съедается запятая в дробной части
 
Вы написали
Цитата
извлечь макросом числа из текста
У вас в ячейке три числа, вот я их и извлек
При извлечении числа из текста съедается запятая в дробной части
 
Цитата
извлечь макросом числа из текста
Код
Sub GetiDigits()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "\d+(,\d+)?"
  For i = 1 To iLastRow
    If .Test(Cells(i, 1)) Then
      Set mo = .Execute(Cells(i, 1))
      For n = 0 To mo.Count - 1
        Cells(i, n + 3) = CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub
Подсчет суммы и количества уникальных значений при фильтре
 
Цитата
при фильтре считались бы уникальные значения слова из словосочетания и их сумма
Макросом попробуйте
Код
Sub test()
Dim arr
Dim dic As Object
Dim dic_Gorox As Object
Dim key
Dim i As Long
Dim iLastRow As Long
Dim rng_vsb As Range
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("C2:E2").ClearContents
     Range("C5:E" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     Set dic_Gorox = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
    With ActiveSheet.AutoFilter.Range
         Set rng_vsb = .Offset(1).SpecialCells(12)
         rng_vsb.Copy Range("D5")
       arr = Range("D5").CurrentRegion.Value
    End With
  For i = 1 To UBound(arr)
    dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) + arr(i, 2)
    If InStr(1, arr(i, 1), "горошек") > 0 Then
      dic_Gorox.Item(arr(i, 1)) = dic_Gorox.Item(arr(i, 1)) + arr(i, 2)
    End If
  Next i
    Range("C2") = dic.Count                           'Разных всего
    Range("D2") = dic_Gorox.Count                     'Разных с горошком
    For Each key In dic_Gorox.Keys
      Range("E2") = Range("E2") + dic_Gorox.Item(key) 'Сумма разных с горошком
    Next
      Range("D5").CurrentRegion.ClearContents
End Sub

Изменено: Kuzmich - 28.10.2021 12:14:19
Нужно разделить варианты ответов символом | (цикл строк и столбцов), Я пытался но не получается.
 
Цитата
Есть вот такой код
Вот и макрос мой пригодился, хотя в теме ТС даже не вспомнил об этом
Объединенить данные одинаковых строк по дате производства авто
 
Цитата
в таблице результата сразу несколько одинаковых строк (кроме года) соединить в диапазон
У меня получилось 134 строки, а у вас 138 ?
Нужно разделить варианты ответов символом |
 
Цитата
после запятой пробел и Заглавная буква
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim Delimiter As String
   Delimiter = "|"
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = ",\s(?=[А-Я])"
   For i = 1 To iLastRow
     If .test(Cells(i, 1)) Then
       Cells(i, 2) = .Replace(Cells(i, 1), Delimiter)
     End If
   Next
 End With
End Sub
Функция в VBA не работает под старым Excel
 
В Excel 2003 есть библиотека Microsoft XML, v6.0
Заполнение датами колонки в таблице данными из другой по нескольким значениям
 
Цитата
как это реализовать макросом
В модуль книги Картотека...
Код
Sub LastDate_()
Dim i As Long
Dim iLastRow As Long
Dim FoundInnos As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  With Workbooks("Журнал КДС.xls").Worksheets("Лист1")
    For i = 2 To iLastRow
     If Cells(i, "D").Interior.ColorIndex = -4142 Then          'нет заливки
      Set FoundInnos = .Columns("H").Find(Cells(i, "D"), , xlValues, xlWhole, xlByRows, xlPrevious)
      If Not FoundInnos Is Nothing Then
        FAdr = FoundInnos.Address
        Do
         If FoundInnos.Offset(, -2) = "положена" Or FoundInnos.Offset(, -2) = "посылка" Then
           Cells(i, "E") = FoundInnos.Offset(, -7)
           Exit Sub
         End If
          Set FoundInnos = .Columns("H").Find(Cells(i, "D"), FoundInnos, xlValues, xlWhole, xlByRows, xlPrevious)
        Loop While FoundInnos.Address <> FAdr
      End If
     End If
    Next
  End With
End Sub

Обе книги должны быть открыты
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 263 След.
Наверх