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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 264 След.
Частичный вывод из TextBox в MsgBox
 
По мотивам кода New
Код
Private Sub CommandButton1_Click()
Dim arr As Variant
    'Me.TextBox1.Text = "Иванов Иван Иванович"
    arr = Split(Me.TextBox1.Text, " ",2)
    MsgBox arr(1) , 64, "Сообщение"
End Sub
из текста разделенного на произвольное количество частей получить фрагмент из последней части
 
UDF
Код
Function iPart(cell$)
Dim mo As Object
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[^\\]+"
   If .test(cell) Then
     Set mo = .Execute(cell)
     iPart = mo(mo.Count - 1)
     .Pattern = "\[.+\]"
     iPart = .Replace(iPart, "")
   Else
     iPart = ""
   End If
 End With
End Function
Найти неповторяющиеся нормы у повторяющихся заказов
 
Цитата
чтоб одинаковые нормы не отображались
Код
Sub iZadacha()
Dim i As Long
Dim iLastRow As Long
Dim iFoundZadacha As Range
Dim FAdr As String
Dim Norma As Range
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("K1:L" & iLastRow).Clear
   Range("A2:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
   For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row
     If Application.WorksheetFunction.CountIf(Range("A2:A" & iLastRow), Cells(i, "K")) > 1 Then
        Set iFoundZadacha = Columns(1).Find(Cells(i, "K"), , xlFormulas, xlWhole)
          FAdr = iFoundZadacha.Address
          Set Norma = iFoundZadacha.Offset(, 1)
          Cells(i, "L") = iFoundZadacha.Row & ", "
        Do
          If iFoundZadacha.Offset(, 1) <> Norma Then
            Cells(i, "L") = Cells(i, "L") & iFoundZadacha.Row & ", "
          End If
          Set iFoundZadacha = Columns(1).FindNext(iFoundZadacha)
        Loop While iFoundZadacha.Address <> FAdr
     End If
   Next
End Sub
Найти неповторяющиеся нормы у повторяющихся заказов
 
Код
Sub iZadacha()
Dim i As Long
Dim iLastRow As Long
Dim iFoundZadacha As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("K1:L" & iLastRow).Clear
   Range("A2:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
   For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row
     If Application.WorksheetFunction.CountIf(Range("A2:A" & iLastRow), Cells(i, "K")) > 1 Then
        Set iFoundZadacha = Columns(1).Find(Cells(i, "K"), , xlFormulas, xlWhole)
          FAdr = iFoundZadacha.Address
        Do
          Cells(i, "L") = Cells(i, "L") & iFoundZadacha.Row & ", "
          Set iFoundZadacha = Columns(1).FindNext(iFoundZadacha)
        Loop While iFoundZadacha.Address <> FAdr
     End If
   Next
End Sub

Макрос выводит в столбец К уникальные задачи, а в столбец L строки, где эти задачи совпадают.
Какие нормы правильные вам решать.
Вывод в msgbox текст из ячяек
 
Только надо
Код
adrs = adrs & vbLf & c.Address(0, 0) & ":  " & c.Offset(0, -3)
Найти неповторяющиеся нормы у повторяющихся заказов
 
Код
двух столбцах значение которых, нужно сравнить и найти ошибку

Что вы подразумеваете под ошибкой? Поясните на примере задачи 1
Как посчитать сумму чисел находящихся одной ячейке, стоимость нескольких услуг прописывается в одну ячейку, нужно посчитать ее сумму
 
Код
как посчитать сумму этой ячейки

Код
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+$"
  For i = 3 To iLastRow
    If .Test(Cells(i, 2)) Then
      Set mo = .Execute(Cells(i, 2))
      For n = 0 To mo.Count - 1
        Cells(i, 3) = Cells(i, 3) + CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub
Определение диапазона объединенной ячейки.
 
Код
    If Cells(KolStrok, 1).MergeCells Then
      iAdr = Cells(KolStrok, 1).MergeArea.Address(False, False)
    End If
Определение диапазона объединенной ячейки.
 
Число строк на странице
Код
Dim KolStrok As Long
    KolStrok = ActiveSheet.HPageBreaks(1).Location.Row - 1

Проверяйте объединенная ли ячейка на границе листа и сдвигайте горизонтальный разрыв
размножить листы и заполнить по условию, ведомость по списку на каждого сотрудника
 
Цитата
создать ведомость на каждого сотрудника
При активном листе список водителей запустить макрос в стандартном модуле
Код
Sub iCreateListFIO()
Dim FIO As String
Dim i As Long
Dim Shablon As Worksheet
Dim TabNomer As Long

  Set Shablon = ThisWorkbook.Worksheets("1")
  For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
    FIO = Split(Cells(i, "B"), " ")(0) & " " & Left(Split(Cells(i, "B"), " ")(1), 1) _
          & "." & Left(Split(Cells(i, "B"), " ")(2), 1) & "."
    TabNomer = Cells(i, "C")
    If Not SheetExist(FIO) Then Shablon.Copy After:=Worksheets(Sheets.Count)
    ActiveSheet.Name = FIO
      Range("B16:B22") = FIO
      Range("H16:H22") = TabNomer
    Worksheets("список водителей").Activate
  Next
End Sub

     'функция проверки наличия листа в файле, лист есть - true
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
Извлечь из текста цифры, расположенные между определенными символами
 
UDF в стандартный модуль
Код
Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d+(?=/)"
   If .test(cell) Then
     iDigits = .Execute(cell)(0)
   Else
     iDigits = ""
   End If
 End With
End Function
Найти номер столбца с последней заполненной ячейкой в строке
 
Код
Sub iLastColumn()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("M2:M" & iLastRow).ClearContents
    For i = 2 To iLastRow
      For j = 10 To 5 Step -1
        If Cells(i, j) <> "" Then
          Cells(i, 13) = Cells(i, j).Column
          Exit For
        End If
      Next
    Next
End Sub
как можно очистить столбец, кроме заголовка?, перед заполнением
 
Цитата
а потом всё смещается вниз
Перед циклом добавьте j=2
Код
j = S2.Cells(Columns(1).Cells.Count, ListCol).End(xlUp).Row + 1
  S2.Range("D2:D" & j).ClearContents
j=2
как можно очистить столбец, кроме заголовка?, перед заполнением
 
Цитата
Как можно очистить столбец, сохраняя заголовок,
Добавить в макрос строку перед циклом
Код
j = S2.Cells(Columns(1).Cells.Count, ListCol).End(xlUp).Row + 1
  S2.Range("D2:D" & j).ClearContents
Пытаюсь настроить перенос строк из общего списка при наличии аргументов и с учетом свободных строк
 
Код
Sub Sotrudnik()
Dim i As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("H3:J" & iLastRow).ClearContents
  For i = 3 To iLastRow
    If Cells(i, "B") = "цех" Then
      Cells(Cells(Rows.Count, "H").End(xlUp).Row + 1, "H") = Cells(i, "A")
    ElseIf Cells(i, "B") = "склад" Then
      Cells(Cells(Rows.Count, "I").End(xlUp).Row + 1, "I") = Cells(i, "A")
    Else
      Cells(Cells(Rows.Count, "J").End(xlUp).Row + 1, "J") = Cells(i, "A")
    End If
  Next
End Sub
Посчитать количество заполненных ячеек между ячейками с заданными словами
 
Код
Sub ПосчитатьЯчейки()
Dim arr
Dim S As String
Dim i As Integer
Dim cell_1 As Range
Dim cell_2 As Range
  arr = Array("Шкафы-купе", "Шкафы", "Комоды", "Прихожие", "Конец таблицы")
  For i = 0 To UBound(arr) - 1
    Set cell_1 = Columns(2).Find(arr(i), , xlValues, xlWhole)
    Set cell_2 = Columns(2).Find(arr(i + 1), , xlValues, xlWhole)
    S = S & arr(i) & ":" & WorksheetFunction.CountA(Range("B" & cell_1.Row + 1 & ":B" & cell_2.Row - 1)) & vbCrLf
  Next
  MsgBox S
End Sub
Как посчитать сумму, когда в ячейках цифры и текст написаны вместе?
 
Код
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
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 264 След.
Наверх