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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 265 След.
Реализовать выбор даты и времени в ячейках, предоставить выбор даты и времени
 
Цитата
Не нашел рабочий вариант
Попробуйте поиск Календарь Слэна
Удаление данных из ячеек по условию с помощью VBA
 
С моим макросом
Код
Sub iClearDann()
Dim iLastCol As Integer
Dim j As Long
  iLastCol = Cells(14, Columns.Count).End(xlToLeft).Column
   For j = iLastCol To 2 Step -1
     If Cells(14, j).Value Mod Range("C6") > 0 And Cells(14, j).Value Mod Range("C6") <= Range("C7") Then
       Cells(16, j).ClearContents
     End If
   Next
End Sub
Изменено: Kuzmich - 08.08.2022 22:30:56
Удаление данных из ячеек по условию с помощью VBA
 
Код
Sub Макрос1()
n = Range("c6")
m = Range("c7")
i = 1
For Each c In Range(Cells(14, 2), Cells(14, Cells(14, Columns.Count).End(xlToLeft).Column))
    If i > n Then i = 1
    If i <= m Then c.Offset(2, 0) = ""
    i = i + 1
Next
End Sub
Удаление данных из ячеек по условию с помощью VBA
 
Так еще
Код
If i <= m Then c.Offset(2, 0) = ""
Удаление данных из ячеек по условию с помощью VBA
 
Цитата
Подскажите, что нужно поправить?
А так
Код
For Each c In Range(Cells(14, 2), Cells(14, Cells(14, Columns.Count).End(xlToLeft).Column))
Удаление данных из ячеек по условию с помощью VBA
 
Цитата
решение данное задачи с помощью макроса
Удаляет столбцы с ненужными данными
Код
Sub DelDann()
Dim iLastCol As Integer
Dim j As Long
  iLastCol = Cells(5, Columns.Count).End(xlToLeft).Column
   For j = iLastCol To 2 Step -1
     If Cells(5, j).Value Mod Range("B2") > 0 And Cells(5, j).Value Mod Range("B2") <= Range("B3") Then
       Columns(j).Delete
     End If
   Next
End Sub
вывод последнего значения в среди повторяющихся имен
 
Цитата
вывести в отдельную таблицу последнее значение относящееся к имени.
Для маши
Код
Sub iKol_vo_LastDate()
Dim iLastName As Range
  Set iLastName = Columns("B").Find(Cells(2, 5), Range("B1"), xlValues, xlWhole, xlByRows, xlPrevious)
  Cells(2, 6) = iLastName.Offset(, 1)
End Sub

Цикл для остальных имен сделайте сами
Замена строчных букв на произвольный символ.
 
UDF
Код
Function iFIO(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[а-яё]"
   If .test(cell) Then
     iFIO = .Replace(cell, "*")
   End If
 End With
End Function
Скрипт поиска значений и перенос строк на новый лист
 
Андрей Коваленко, желательно добавить проверку наличия в книге определенного листа
Код
Sub TEST_()
  Application.ScreenUpdating = False
  Dim rest, sh&, iCell As Range
  rest = Array("Атриум", "Большая Никитская", "Геленджик", "Анапа")
  For sh = 0 To UBound(rest)
   If SheetExist(CStr(rest(sh))) Then
    With Worksheets(rest(sh))
      .Range("A6:I10000").Clear
      For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
        If iCell = rest(sh) Then
          iCell.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End If
      Next iCell
    End With
   Else
     MsgBox "В книге нет листа с именем: " & rest(sh)
   End If
  Next
  Application.ScreenUpdating = True
End Sub
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
Скрипт поиска значений и перенос строк на новый лист
 
Код
iCell.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, "A")
как в экселе найти второй или третий или четвертый плюс в одной ячейке, поиск вхождения 1 или 2 или 3 плюса(+)
 
Пусть пример в ячейке А1, после выполнения макроса в столбцах правее позиция каждого плюса
Код
Sub test()
Dim mo As Object
Dim j As Integer
 With CreateObject("vbscript.regexp")
         .Global = True
     .Pattern = "\+"
          Set mo = .Execute(Cells(1, "A"))
     If mo.Count Then
         For j = 0 To mo.Count - 1
           Cells(1, 2 + j) = mo.Item(j).firstindex + 1
         Next
     End If
 End With
End Sub
Работа макроса при изменении количества строк в таблице
 
Определяете последнюю строку в вашей таблице и от нее вставляете или удаляете оговорку
Код
    Dim iLastRow As Long
      iLastRow = Range("G10").End(xlDown).Row
.......................................................................
      xSheet.Range("D" & iLastRow + 2 & ":I" & iLastRow + 8).ClearContents

Как вытащить из строки подстроку по маске расположенной в случайном порядке?
 
Цитата
возможно получить такой результат
Используйте
Код
Function iFio(iCell As Range) As String
Dim re
Set re = CreateObject("VBScript.RegExp")
     re.Global = True
'     re.MultiLine = True
re.Pattern = "\|([А-ЯЁ][а-яё]+ [А-ЯЁ]\.[А-ЯЁ]\.?)\|"
    iFio = re.Execute(iCell)(0).SubMatches(0)
End Function
Как вытащить из строки подстроку по маске расположенной в случайном порядке?
 
Цитата
подскажите, как в маску добавить знак "|" ?
Вы в файле покажите варианты написания ФИО в ячейке и какой результат вы желаете получить
Цитата
Если я корректирую код добавляя "|" так
Надо вставлять \|
Изменено: Kuzmich - 25.06.2022 23:11:11
Как вытащить из строки подстроку по маске расположенной в случайном порядке?
 
UDF
Код
Function iFio(iCell As Range) As String
Dim re
Set re = CreateObject("VBScript.RegExp")
     re.Global = True
re.Pattern = "[А-ЯЁ][а-яё]+ [А-ЯЁ]\.([А-ЯЁ]\.)?"
    iFio = re.Execute(iCell)(0)
End Function
Разделить данные Листа на несколько отдельных листов
 
В исходный файл с одним листом Лист1 вставьте в стандартный модуль код.
Код
Sub Tablica()
Dim NewSheet As Worksheet
Dim iLR As Long
Dim iRow_Begin As Long
Dim iNomer As String
Dim FoundNomerSwerki As Range
Dim FAdr As String
Application.ScreenUpdating = False
    Set FoundNomerSwerki = Columns("C:D").Find("Номер сверки заказа:", , xlValues, xlWhole)
      FAdr = FoundNomerSwerki.Address
    Do
      iRow_Begin = FoundNomerSwerki.Row                     'начало очередного диапазона по номеру сверки
      iNomer = FoundNomerSwerki.Offset(, 1)                 'номер сверки
      iLR = FoundNomerSwerki.Offset(5).End(xlDown).Row      'конец  очередного диапазона
      
      'здесь копируем диапазон от iRow_Begin до iLR и вставляем в лист с именем iNomer
      'если такого листа нет, то добавляем лист
        If Not SheetExist(iNomer) Then                      'функция проверки наличия листа в файле
          Set NewSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
          NewSheet.Name = iNomer
          With Worksheets("Лист1")
            .Range(.Cells(iRow_Begin, "C"), .Cells(iLR, "Z")).Copy Range("A1")
            .Activate
          End With
        End If
      Set FoundNomerSwerki = Columns("C:D").FindNext(FoundNomerSwerki)
    Loop While FoundNomerSwerki.Address <> FAdr
Application.ScreenUpdating = True
End Sub

Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function


При активном листе Лист1 запустите макрос Tablica()
Разделить данные Листа на несколько отдельных листов
 
Цитата
Пример того, что должно получаться прикладываю
Я так понимаю, что у вас есть файл с одним листом Лист1 и надо сформировать n-ое количество листов под именами номера заказа.
Имена заказов у вас уникальные?
Смущает, что вы
Цитата
В макросах ни бум-бум
как будете разбираться?
Как из строки удалить числа с их единицами измерения, в строчках есть ватность а где то нет, нужно убрать и чтобы структура осталась не изменой
 
ТС писал
Цитата
надо не только вт убрать, а убрать например "(857Вт)
тогда
Код
re.Pattern = " \(\d+ ?Вт\)"
Частичный вывод из 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
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 265 След.
Наверх