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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 203 След.
Убрать одиночный символ из текстовой строки с разделителями
 
Цитата
замена регулярками
Текст в А1, результат в А2
Код
Sub iTxt()
Dim mo As Object
Dim n As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .MultiLine = True
     .Pattern = "[а-яё]+—?[а-яё]+?(?=%%%)"
     If .test(Cells(1, 1)) Then
       Range("A2") = ""
       Set mo = .Execute(Cells(1, 1))
         For n = 0 To mo.Count - 1
          Range("A2") = Range("A2") & mo.Item(n) & "%%%"
         Next
          Range("A2") = Left(Range("A2"), Len(Range("A2")) - 3)
    End If
 End With
End Sub
Склонение месяца на украинском языке (макросом)
 
При этом в русской версии тот же макрос выдает в ячейке В1
05 октября 2018 року
т.е. месяц склоняется
Поиск данных
 
Цитата
Как быть в этом случае?  
Макрос надо писать
Можно ли задавать время задержки в долях секунд?
 

Код
Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
Sub iDelay()
Sleep 500
End Sub

Изменено: Kuzmich - 17 Окт 2018 18:07:09
Макрос, оставляющий строки по наличию определённых кодов
 
Цитата
но только если искомый код находится в поле под этой фамилией
Код у вас в столбце А, а фамилии в столбце В.
И где это поле под этой фамилией?
Макрос, оставляющий строки по наличию определённых кодов
 
Цитата
нужно вывести названия полей (фамилии), находящиеся в столбце B
А каким образом Сидоров С.С. оказался в строке 7 листа ИТОГ?
Разделить буквы и цифры
 
Код
Sub iSumma()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    Cells(1, 1) = Cells(1, 1) + Val(Cells(i, 1))
  Next
End Sub
Расчёт значения при выборе определенных данных из выпадающего списка
 
Цитата
И если добавить работы с другими нормами, то под каждые нормы (не 0,25 выше 1), нужно отдельно всё описывать
На листе работы норма у вас в столбце С, а в столбец D пропишите прибавку
Расчёт значения при выборе определенных данных из выпадающего списка
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Columns("A:C")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Norma As Double
 With Worksheets("Работы")
    Set FoundCell = .Columns(1).Find(Cells(Target.Row, 1), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Norma = FoundCell.Offset(, 2)
       If Cells(Target.Row, 3) = 1 Then
         Cells(Target.Row, 4) = Norma
       Else
         Cells(Target.Row, 4) = Norma + 0.25 * (Cells(Target.Row, 3) - 1)
       End If
     End If
 End With
 End If
  Application.EnableEvents = True
End Sub
Расчёт значения при выборе определенных данных из выпадающего списка
 
Цитата
только такой порядок может быть?
Если вы хотите другой порядок, то надо переделывать макрос под изменение или работы или количества
Расчёт значения при выборе определенных данных из выпадающего списка
 
Сначала проставляете количество, затем выбор работы
Расчёт значения при выборе определенных данных из выпадающего списка
 
Норма изменяется в той строке, где был выбор из списка
Расчёт значения при выборе определенных данных из выпадающего списка
 
Цитата
но норма не пересчитывается
Макрос в модуль листа. Срабатывает при изменении в столбце А (при выборе из выпадающего списка)
Расчёт значения при выборе определенных данных из выпадающего списка
 
Цитата
Пользователь должен ввести цифру (единицу измерения: метр,шлейф или иную), и в соответствии с выбранным значением из выпадающего списка
В модуль листа СМЕТА ОСТ
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Columns("A")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Norma As Double
 With Worksheets("Работы")
    Set FoundCell = .Columns(1).Find(Target, , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Norma = FoundCell.Offset(, 2)
       If Target.Offset(, 2) = 1 Then
         Target.Offset(, 3) = Norma
       Else
         Target.Offset(, 3) = Norma + 0.25 * (Target.Offset(, 2) - 1)
       End If
     End If
 End With
 End If
  Application.EnableEvents = True
End Sub
Вводите в столбец С количество, затем из выпадающего списка выбираете работу
Записать в одну строку макросом
 
В модуль Sheet1
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Columns("C:F")) Is Nothing Then
        Application.EnableEvents = False
Dim j As Integer
  Range("A" & Target.Row).ClearContents
    For j = 3 To 6
      If Not IsEmpty(Cells(Target.Row, j)) Then
        Range("A" & Target.Row) = Range("A" & Target.Row) & Split(Cells(1, j), " ")(1) & ", "
      End If
    Next
      Range("A" & Target.Row) = Left(Range("A" & Target.Row), Len(Range("A" & Target.Row)) - 2)
  End If
    Application.EnableEvents = True
End Sub
Расчёт значения при выборе определенных данных из выпадающего списка
 
Цитата
Ничего лишнего
А 4 скрытых листа?
Автозаполнение таблицы расхода топлива
 
Макрос в модуль листа Рапорт
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("GA1")) Is Nothing Then
        Application.EnableEvents = False
 Dim iMonth As Integer
 Dim i As Long
 Dim iLastRow As Long
 Dim n As Integer
 Dim OstatokEndDay As Double
 Dim Rasxod As Double
 Dim iStroka As Long
 Dim Polucheno As Double
   iMonth = Target.Value
  Range("A63:I78,J63:R78,AB63:AJ78,AK63:AQ78").ClearContents     'очищаем данные на листе Рапорт
  iStroka = 63
With Worksheets("Журнал подій")
    iLastRow = .Range("A3").End(xlDown).Row     'конец таблицы на листе журнал
  For i = 4 To iLastRow
    If Month(.Cells(i, "A")) = iMonth Then      'месяц даты совпадает с выбранным
       If i <> 4 Then OstatokEndDay = .Cells(i - 1, "S") 'остаток на конец дня
      If .Cells(i, "S") = "" Then               'остаток пусто
          n = 0                                 'число дней в диапазоне
        Do        'в диапазоне одинаковых дат вычисляем расход и получено
          Rasxod = Rasxod + .Cells(i + n, "R")
          Polucheno = Polucheno + .Cells(i + n, "Q")
            n = n + 1
        Loop While .Cells(i + 1 + n, "A") = .Cells(i + 1, "A")
          Cells(iStroka, "A") = .Cells(i + n, "A")
          Cells(iStroka, "J") = OstatokEndDay
          Cells(iStroka, "AB") = Polucheno
          Cells(iStroka, "AK") = OstatokEndDay + Polucheno - Rasxod
            iStroka = iStroka + 1
            i = i + n
            Rasxod = 0
            Polucheno = 0
        Else
          If i = 4 Then OstatokEndDay = .Cells(i, "S")  'остаток на конец дня
        End If
      End If
  Next
End With
End If
    Application.EnableEvents = True
End Sub
Автозаполнение таблицы расхода топлива
 
Цитата
На листе Рапорт введены данные, которые должны получиться при выборе месяца 7
А месяц 8 вы будете выбирать в этом файле рапорт.xlsm (113.74 КБ)
Приведите данные, которые должны получиться при выборе месяца 8
Макрос "не видит" вещественные числа
 
Код
     Selection.AutoFilter Field:=7, Criteria1:=">=" & Replace([I2], ",", ".") _
        , Operator:=xlAnd, Criteria2:="<=" & Replace([J2], ",", ".")
Автозаполнение таблицы расхода топлива
 
Три темы в обсуждении, а про эту вы забыли?
Поиск по одному параметру и последующее перемещение целой строки на второй лист, макрос
 
На листе Sheet1 создан элемент управления Поле со списком, заполненный номерами заказов.
Двойной клик по выбранному элементу в списке переносит эту строку с этим номером  на лист КудаПеренести
Поиск по одному параметру и последующее перемещение целой строки на второй лист, макрос
 
Цитата
при вводе определенного "номера заказа"
Куда вы собираетесь вводить номер?
Цитата
вся строка должна удалятся с первого листа и, соответственно переноситься на лист 2
В какое место листа2 ? При этом на листе1 строки должны сдвигаться ?
Автозаполнение таблицы расхода топлива
 
Попробуйте макрос в модуле листа Бланк, срабатывает на изменении значения ячейки G1
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("G1")) Is Nothing Then
        Application.EnableEvents = False
 Dim iMonth As Integer
 Dim i As Long
 Dim iLastRow As Long
 Dim n As Integer
 Dim OstatokEndDay As Double
 Dim Rasxod As Double
 Dim iStroka As Long
 Dim iDate As Date
 Dim Polucheno As Double
        iMonth = Target.Value
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
  Range("A4:E" & iLastRow).ClearContents     'очищаем данные на листе Бланк
  iStroka = 4
With Worksheets("Лист1")
  iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  For i = 2 To iLastRow
    If Month(.Cells(i, "A")) = iMonth Then      'месяц даты совпадает с выбранным
      If i <> 2 Then OstatokEndDay = .Cells(i - 1, "E") 'остаток на конец дня
      If .Cells(i, "E") = "" Then               'остаток пусто
          n = 0                                 'число дней в диапазоне
        Do
          Rasxod = Rasxod + .Cells(i + 1 + n, "D")
          Polucheno = Polucheno + .Cells(i + 1 + n, "C")
            n = n + 1
        Loop While .Cells(i + 1 + n, "A") = .Cells(i + 1, "A")
          Cells(iStroka, "A") = .Cells(i + n, "A")
          Cells(iStroka, "B") = OstatokEndDay
          Cells(iStroka, "D") = Polucheno
          Cells(iStroka, "E") = OstatokEndDay + Polucheno - Rasxod
          OstatokEndDay = .Cells(i + n, "E")    'остаток на конец дня
            iStroka = iStroka + 1
            i = i + n
            Rasxod = 0
            Polucheno = 0
      Else
        If i = 2 Then OstatokEndDay = .Cells(i, "E")  'остаток на конец дня
      End If
    End If
  Next
End With
End If
    Application.EnableEvents = True
End Sub
Перенос данных из заданных областей на отдельный лист с сортировкой
 
Цитата
Ни у кого нету идей?
Находясь на листе Итоги, запустите макрос
Код
Sub Sbor()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim j As Integer
Dim FoundCell As Range
Dim FAdr As String
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
  Range("B7:G" & iLastRow).ClearContents
      i = 7    'начальная строка в таблице на листе Итоги
    For Each Sht In Worksheets
      If Sht.Name <> "Итоги" Then        ' кроме листа "Итоги"
        With Sht
    Set FoundCell = .Columns(1).Find("поставщик:", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
        FAdr = FoundCell.Address
        n = FoundCell.Row + 3    'начальная строка в таблице поставщика
      Do
        Cells(i, "B") = FoundCell.Offset(, 1)      'поставщик
        For j = n To .Cells(n - 1, "K").End(xlDown).Row
          Cells(i, "C") = .Cells(j, "K")             'дата
          Cells(i, "D") = .Cells(j, "J")             'накладная
          Cells(i, "F") = .Cells(j, "L")             'сумма
          Cells(i, "G") = .Cells(j, "M")             'налог
          i = i + 1
        Next
         Set FoundCell = .Columns(1).FindNext(FoundCell)
          n = FoundCell.Row + 3
      Loop While FoundCell.Address <> FAdr
     End If
        End With
      End If
    Next
End Sub
"Слияние" строк с одинаковыми значениями в двух столбцах
 
Цитата
если поставить значения к примеру в колонку AL и AK, то макрос уже не достает туда
В моем макросе замените в строке
Код
arr = Range("A1:O" & iLastRow).Value
O на AL
"Слияние" строк с одинаковыми значениями в двух столбцах
 
Цитата
Значения после столбцов A и B - не пересекаются в одном столбце.
Код
Sub Tablica()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim arr
Dim arr1
 iLastRow = Range("A1").End(xlDown).Row
 arr = Range("A1:O" & iLastRow).Value
 ReDim arr1(1 To UBound(arr) / 2, 1 To UBound(arr, 2))
  For i = 1 To UBound(arr) Step 2
    arr1(Int(i / 2) + 1, 1) = arr(i, 1)
    arr1(Int(i / 2) + 1, 2) = arr(i, 2)
      For j = 3 To UBound(arr, 2)
        If arr(i, j) = "" Then
          arr1(Int(i / 2) + 1, j) = arr(i + 1, j)
        Else
          arr1(Int(i / 2) + 1, j) = arr(i, j)
        End If
      Next
  Next
    Range("A13").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub
"Слияние" строк с одинаковыми значениями в двух столбцах
 
Цитата
но в остальных столбцах, разные значения которые разбросаны рандомно.
Значения в двух строках одной даты одного столбца могут могут быть или они не пересекаются?
Аналог функции IsNumeric для текста
 
Цитата
Во, другое дело
Что-то Кузя1972 не проявляется
Аналог функции IsNumeric для текста
 
БМВ написал
Цитата
им хлеба не надо, дай что нить зарегулярить,
Код
Sub iPersent()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim j As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "\d+(?=%)"
     If .test(Cells(1, 1)) Then
       Set mo = .Execute(Cells(1, 1))
           i = 1
         For n = 0 To mo.Count - 1
           Cells(i, "B") = CDbl(mo(n))
           i = i + 1
         Next
     End If
   .Pattern = "[а-я]+"
     If .test(Cells(1, 1)) Then
       Set mo = .Execute(Cells(1, 1))
           i = 1
         For n = 0 To mo.Count - 1
           Cells(i, "C") = mo(n)
           i = i + 1
         Next
    End If
 End With
End Sub
Аналог функции IsNumeric для текста
 
Цитата
тут есть два Кузьмы
Ну Кузя1972 еще проявится
Изменено: Kuzmich - 7 Сен 2018 20:16:18
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 203 След.
Наверх