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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 262 След.
Добавление строки по условию в таблицу c помощью VBA
 
вопрос к Mershik, его макрос
Автоматический запуск макроса при изменении данных
 
Аркадий Бочкарев, написал
Цитата
Скрывает строки если ячейки пустые
а в коде
Код
If Not IsEmpty(c) Then

это, если ячейка не пустая. Так, что вы проверяете?
Поиск соответствия всех значений, используя столбец, содержащий дубликаты.
 
Excelman,
Цитата
чтоб работало и на 2003 - можно чем то заменить СЧЁТЕСЛИМН?
Изучайте https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=111226
Поиск соответствия всех значений, используя столбец, содержащий дубликаты.
 
Find и  FindNext
Как посчитать количество (в т.ч. диапазон) целых чисел в одной ячейке разделенных запятой?
 
Мне даже страшно смотреть на такие формулы  8-0
Попробуйте макросом
Код
Sub iSummaKol()
Dim arr
Dim iSummaKol As Long
Dim cell As Range
Dim i As Integer
    iSummaKol = 0
  For Each cell In Range("B1:E2")
    If Not IsEmpty(cell) Then
        arr = Split(cell, ",")
        For i = 0 To UBound(arr)
          If InStr(1, arr(i), "-") > 0 Then
              iSummaKol = iSummaKol + Split(arr(i), "-")(1) - Split(arr(i), "-")(0) + 1
          Else
              iSummaKol = iSummaKol + 1
          End If
        Next
    End If
  Next
    Range("A1") = iSummaKol
End Sub
Принятнуть значения сразу по нескольким аргументам
 
na-ers,
Скажите, по какой необходимости порядок Овощи, фрукты, макароны на листах разный?
Как посчитать количество (в т.ч. диапазон) целых чисел в одной ячейке разделенных запятой?
 
Андрей Алексеевич,
Цитата
в файле только один пример, но у меня таких ячеек 8+1(итог) много
Приведите реальный пример.
Да и формулы я не писал.
Как посчитать количество (в т.ч. диапазон) целых чисел в одной ячейке разделенных запятой?
 
БМВ,
Я сам же добавил в первую ячейку 1-15,20 и забыл. Склероз
Как посчитать количество (в т.ч. диапазон) целых чисел в одной ячейке разделенных запятой?
 
Цитата
в т.ч. диапазон
А у меня в вашем примере получилось 25
Сортировка в выделяемом диапазоне по определенной колонке
 
EvaAleks,
Код
 iLastRow = Cells(Rows.Count, "F").End(xlUp).Row

Эта команда ищет последнюю строку в столбце F (=82)
Поэтому и сортирует B1:F82
Сортировка в выделяемом диапазоне по определенной колонке
 
Код
Sub iSort_3()
Dim iLastRow As Long
    iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
    Range("A1:C" & iLastRow).Sort Range("C1"), xlDescending, Header:=xlYes
End Sub
Ошибка runtime error 1004
 
Цитата
ошибка runtime error 1004 метод autofill
Может все-таки AutoFilter
Видимо ТС желает оставить в столбце А листа "1" значения, которые есть в массиве
Array("10503", "121", "273", "3785", "4314", "539", "558", "5717", "5726")
Суммирование данных по задаваемому диапазону, Необходимо просуммировать данные по граничным точкам диапазона
 
Код
Sub StartEnd()
Dim iLastRow As Long
Dim FoundCell As Range
Dim FRow As Long
Dim ERow As Long
Dim j As Integer
  Rows(27).ClearContents
 For j = 1 To 9 Step 4
   iLastRow = Cells(Rows.Count, j).End(xlUp).Row
  With Range(Cells(1, j), Cells(iLastRow, j))
    Set FoundCell = .Find("0", , xlValues, xlWhole)
       FRow = FoundCell.Row
         Set FoundCell = .FindNext(FoundCell)
       ERow = FoundCell.Row
       Cells(27, j + 2) = WorksheetFunction.Sum(Range(Cells(FRow, j + 2), Cells(ERow, j + 2)))
  End With
 Next
End Sub
Сумма и счет по диапазону дат и диапазону номеров чеков
 
Цитата
для Excel 2003
Цитата
Нужно подсчитать количество заказов в ячейке B75
В модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("B70:B74")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundTowar As Range
Dim iDate1 As Date
Dim iDate2 As Date
Dim Check1 As Integer
Dim Check2 As Integer
Dim FAdr As String
  Check1 = Split(Range("B73"), " ")(1)
  Check2 = Split(Range("B74"), " ")(1)
  Range("B75") = 0
  Set FoundTowar = Range("C2:C42").Find(Range("B70"), , xlValues, xlWhole)
    If Not FoundTowar Is Nothing Then
      FAdr = FoundTowar.Address
      Do
        If Cells(FoundTowar.Row, "F") >= Range("B71") And Cells(FoundTowar.Row, "F") <= Range("B72") Then
          If Split(Cells(FoundTowar.Row, "D"), " ")(1) >= Check1 Or _
             Split(Cells(FoundTowar.Row, "D"), " ")(1) <= Check2 Then
             Range("B75") = Range("B75") + Cells(FoundTowar.Row, "H")
          End If
        End If
        Set FoundTowar = Range("C2:C42").FindNext(FoundTowar)
      Loop While FoundTowar.Address <> FAdr
    End If
 End If
    Application.EnableEvents = True
End Sub
Подставить соответствующий текст при ошибке извлечения чисел из текста в строке.
 
Цитата
нужно вычленить краткое название:
UDF
Код
Function iMagnit(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "D.+(?=mm)"
   If .test(cell) Then
       iMagnit = .Execute(cell)(0) & "mm"
     .Pattern = "\(сила притяжения (.+)(?=кг)"
    If .test(cell) Then
      iMagnit = iMagnit & " (" & .Execute(cell)(0).SubMatches(0) & " кг)"
    Else
      iMagnit = iMagnit & "(-кг)"
    End If
   Else
     iMagnit = ""
   End If
 End With
End Function
Регулярные выражения. Можно ли ссылаться на группу за пределами метода Replace?
 
Цитата
найти в тексте градусы Цельсия/Фаренгейта
Поскольку примера нет, то UDF
Код
Function iDegree(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "(\d+)(C|F)"
   If .test(cell) Then
     If .Execute(cell)(0).SubMatches(1) = "C" Then
       iDegree = "Температура в градусах Цельсия: " & .Execute(cell)(0).SubMatches(0)
     Else
       iDegree = "Температура в градусах Фаренгейта: " & .Execute(cell)(0).SubMatches(0)
     End If
   Else
     iDegree = ""
   End If
 End With
End Function
Суммирование значений, вводимых в другой ячейке
 
А я еще проверяю If WorksheetFunction.IsNumber(Target) Then
Суммирование значений, вводимых в другой ячейке
 
Сложение чисел, вводимых в одной ячейке, в другой ячейке
В модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("A1")) Is Nothing Then
     Application.EnableEvents = False
     Target.Copy
     Range("A2").PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
        Application.CutCopyMode = False
  End If
    Application.EnableEvents = True
End Sub
Выводится два сообщения одновременно. Как разделить?
 
Цитата
при нажатии на кнопку Заполнить заявку"  строка не добавляется, но при этом выходит сообщение "Заказ успешно создан". Как это убрать
Код
Sub Оформить_заявку()
  If Cbx_org.Text <> "" Then
    MsgBox "Заказ успешно создан.", vbInformation
  Else
    MsgBox "Заполните поле Подразделение"
  End If
End Sub

А какие строки должны добавляться?
Создание окна с сообщением при выполнении действия
 
MsgBox "Документ успешно создан"
Поиск диапазона ячеек с помощью VBA
 
Применить findnext
Массив имён листов, которые в названии содержат символ
 
Посмотрите допустимые символы в имени
сообщение об ошибке, если:
Имя более 31 символа
Имя содержит любой из следующих символов:/\ *? []
@# $% &() + ~ `" ':;., |  не рекомендуется
Подставить выбор данных из таблиц со столбца по выбору месяца в ячейке D1
 
Цитата
месяц из выпадающего списка на листе 4, подтягивались данные из столбца "Расход",
Макрос в модуль Лист4
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then
Dim i As Integer
Dim FoundMonth As Range
Dim iMonth As String
    Application.EnableEvents = False
      iMonth = Target
    For i = 4 To 5                  'цикл по услугам
      With Worksheets(Cells(2, i).Value)
        Set FoundMonth = .Rows(2).Find(iMonth, , xlValues, xlWhole)
        .Range(.Cells(3, FoundMonth.Column + 1), .Cells(5, FoundMonth.Column + 1)).Copy
        Cells(3, i).PasteSpecial xlValues
      End With
    Next
  End If
    Application.EnableEvents = True
End Sub
Удаление или обновление QR-кода
 
Код
Sub DelPicture()
Dim sh As Shape
  For Each sh In ActiveSheet.Shapes
   If sh.Name Like "BarCodeCtrl*" Then
     sh.Delete
   End If
  Next
End Sub
Удалить столбцы через один
 
Код
Sub DelColumns()
Dim iLastCol As Integer
Dim j As Integer
  iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
  For j = iLastCol To 3 Step -2
    Columns(j - 1).Delete
  Next
End Sub
Добавить 8495- к телефонам + убрать лишние пробелы после объединения в таблице
 
Цитата
Добавить 8495- к телефонам
Для вашего примера UDF
Код
Function Telefon(cell As String)
 Dim re As Object
 Dim temp As String
 Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(-|\s|\+|\(|\))"
    re.Global = True
      temp = re.Replace(cell, "")
    re.Pattern = "(\d{3})?(\d{3})(\d{2})(\d{2})"
    If Len(temp) = 10 And Left(temp, 3) = 495 Then
      Telefon = re.Replace(temp, "8$1-$2-$3-$4")
    Else
      Telefon = re.Replace(temp, "8495-$2-$3-$4")
    End If
End Function
Сумма промежуточных итогов в умной таблице
 
Цитата
посчитать сумму значений за этаж
Код
Sub iItog()
Dim Rng As Range
  For Each Rng In Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(2, 1).Areas
    Rng.Cells(0, 2) = WorksheetFunction.Sum(Rng)
    Rng.Cells(0, 2).NumberFormat = "#,##0.00"
  Next
End Sub
Проверить правильный ввод двух чисел со знаком умножения между ними
 
Цитата
В случае дробного хотелось бы после запятой больше одного знака считать ошибкой.
UDF
Код
Function iRazmer(cell As String)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+([,|\.]\d+)?[\*|x|х]\d+([,|\.]\d+)?"
   If .test(cell) Then
     If Len(.Execute(cell)(0).SubMatches(0)) > 2 Or Len(.Execute(cell)(0).SubMatches(1)) > 2 Then
       iRazmer = "Введено больше одного знака после запятой"
     Else
       iRazmer = .Execute(cell)(0)
     End If
   Else
     iRazmer = ""
   End If
 End With
End Function
Удалить определенное количество строк в одной таблице исходя из данных в другой
 
Цитата
На ЛИСТ0 удалить строки со значением ЛИСТ1-СтолбецB в кол-ве ЛИСТ1-(5-СтолбецC)
Цитата
Удалить определенное количество строк
При активном Лист0 запустить макрос, удаляет строки в столбце А
Код
Sub DelRows()
Dim i As Long
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim n As Integer
Dim Kol As Integer
Dim cell As Range
Application.ScreenUpdating = False
  With Worksheets("Лист1")
    For i = iLastRow To 2 Step -1
      Set cell = .Columns(2).Find(Cells(i, "A"), , xlValues, xlWhole)
      If Not cell Is Nothing Then      'нашли значение на лист1 в столбце А
        n = cell.Offset(, 1)           'сколько строк удалить
        Kol = WorksheetFunction.CountIf(Range("A1:A" & iLastRow), Cells(i, "A"))
        If Kol >= n Then               'Kol - количество ячеек со значением в столбце А
          If n <> 0 Then
           Do
             Cells(i, "A").Delete
              i = i - 1
           Loop While WorksheetFunction.CountIf(Range("A1:A" & iLastRow), cell) <> Kol - n
              i = i - (Kol - n) + 1
          End If
        End If
      End If
    Next
  End With
Application.ScreenUpdating = True
End Sub
Заключить в скобки цифры на определенных позициях в тексте
 
Цитата
выбрать определенные цифры и заключить в скобки
UDF
Код
Function iSkobki(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "(\d{2})(\d{14})(\d{2})(.+)"
   If .test(cell) Then
     iSkobki = .Replace(cell, "($1)$2($3)$4")
   Else
     iSkobki = ""
   End If
 End With
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 262 След.
Наверх