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

Страницы: 1 2 3 4 5 6 7 След.
вытащить с ячейки только буквы
 
Похоже что вот так:
Код
=ЕСЛИ(ЕЧИСЛО(ЗНАЧЕН(ПСТР($A$1;СТОЛБЕЦ()-1;1)));"";ПСТР($A$1;СТОЛБЕЦ()-1;1))
Макрос проверки правильности ввода СНИЛС в textbox
 
Похоже на то?
Изменено: GRIM - 5 Дек 2019 17:45:14
поставить двоеточие перед цифрой
 
Я поправил формулу в исходном сообщении.
Выбор нескольких значений из заголовка таблицы.
 
В модуль листа:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("Таблица1")) Is Nothing Then
        x = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 2 To x
            If Cells(Target.Row, i) <> "" Then
                y = y & " " & Cells(1, i)
            End If
        Next
    Cells(Target.Row, 8) = Trim(y)
    End If
End Sub
Изменено: GRIM - 2 Дек 2019 09:52:13
поставить двоеточие перед цифрой
 
Код
=ТЕКСТ(C2;"ЧЧ:ММ:СС")&":"&D2
Изменено: GRIM - 2 Дек 2019 09:06:16
Блокировка работы с другими книгами Excel при открытой UserForm
 
Поставьте у формы свойство ShowModal = False
Изменено: GRIM - 2 Дек 2019 07:32:16
Построить гистрограмму по двум параметрам и одному значению
 
Ничего не понял, но может быть так, через сводную:
Поиск позиции наименьшего положительного числа, Поиск позиции наименьшего положительного числа
 
Возможно так:
Код
=СМЕЩ(B2;1;ПОИСКПОЗ(НАИМЕНЬШИЙ(C4:N4;СЧЁТ(C4:N4)-СЧЁТЕСЛИ(C4:N4;">0")+1);C4:N4;0))
Всплывающее окно с арифметической разницей чисел из двух смежных ячеек.
 
Мне вариант от БМВ, даже больше нравится.
Думаю что если поменять местами строчки:
Код
        LastTarget.Validation.Delete
        Set LastTarget = Intersect(Target, Range("Таблица1"))
то ошибка не будет повторяться.
Всплывающее окно с арифметической разницей чисел из двух смежных ячеек.
 
Если все-таки нужно всплывающим окном, то можно вот так в модуль листа:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("Таблица1")) Is Nothing Then
        MsgBox "Остаток: " & Cells(Target.Row, 1) - Cells(Target.Row, 2)
    End If
End Sub
Сколько дней осталось до события, формула
 
Делал когда-то что-то подобное:
Код
=ЕСЛИОШИБКА(ЕСЛИ($C$6+1="";"Введите дату ДД.ММ.ГГГГ";ЕСЛИ($C$6+1=D7;"0 дн.";ЕСЛИ(РАЗНДАТ($C$6+1;D7;"y")=0;"";РАЗНДАТ($C$6+1;D7;"y")&ЕСЛИ(РАЗНДАТ($C$6+1;D7;"y")=1;" год ";ЕСЛИ(РАЗНДАТ($C$6+1;D7;"y")>=5;" лет ";ЕСЛИ((РАЗНДАТ($C$6+1;D7;"y")>1)*(РАЗНДАТ($C$6+1;D7;"y")<5);" года "))))&ЕСЛИ(РАЗНДАТ($C$6+1;D7;"ym")=0;"";РАЗНДАТ($C$6+1;D7;"ym")&ЕСЛИ(РАЗНДАТ($C$6+1;D7;"ym")=1;" месяц ";ЕСЛИ(РАЗНДАТ($C$6+1;D7;"ym")>=5;" месяцев ";ЕСЛИ((РАЗНДАТ($C$6+1;D7;"ym")>1)*(РАЗНДАТ($C$6+1;D7;"ym")<5);" месяца "))))&ЕСЛИ(РАЗНДАТ($C$6+1;D7;"md")=0;"";РАЗНДАТ($C$6+1;D7;"md"))&ЕСЛИ((РАЗНДАТ($C$6+1;D7;"md")=1)+(РАЗНДАТ($C$6+1;D7;"md")=21);" день ";ЕСЛИ((РАЗНДАТ($C$6+1;D7;"md")>=5)*(РАЗНДАТ($C$6+1;D7;"md")<=20)+(РАЗНДАТ($C$6+1;D7;"md")>=25);" дней";ЕСЛИ((РАЗНДАТ($C$6+1;D7;"md")>1)*(РАЗНДАТ($C$6+1;D7;"md")<5)+(РАЗНДАТ($C$6+1;D7;"md")>21)*(РАЗНДАТ($C$6+1;D7;"md")<25);" дня";"")))));"Что-то введено не так…")
При вводе значения в ячейку удалять его повтор в строке
 
Как вариант:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
x = Cells(1, Columns.Count).End(xlToLeft).Column - 1
For i = 2 To x
    If Cells(Target.Row, i) = "" Then
        GoTo n
    ElseIf Target = Cells(Target.Row, i) And i <> Target.Column Then
        Cells(Target.Row, i) = ""
    End If
n:
Next
End Sub
в модуль листа.
Удаляется первая строка при сохранении листа в отдельный файл, Удаляется первая строка при сохранении листа в отдельный файл
 
Цитата
TMD написал:
название 2 листа не меняется на исходное а остается "ТЕМП"
Да, действительно упустил этот момент. Нужно было добавить возврат старого имени после отмены сохранения:
Код
If cFileName = False Then ActiveSheet.Name = y: Exit Sub
Удаляется первая строка при сохранении листа в отдельный файл, Удаляется первая строка при сохранении листа в отдельный файл
 
Дело в том что при копировании листа у Вас срабатывает процедура:
Код
Private Sub Worksheet_Activate()
и выполняется уже на скопированном листе и вот этой проверкой:
Код
    If (Not Not arrTr) <> 0 Then
        .Cells(1, 1).Resize(UBound(arrTr) + 1, 13) = arrTr
    End If
и затирается эта строка.
Как вариант временно менять имя исходного листа и проверять процедуру Private Sub Worksheet_Activate() только на это имя, а потом возвращать имя назад.
Изменено: GRIM - 20 Ноя 2019 16:04:09
Как выделить цветом столбец с фильтром
 
Ну как вариант так:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim x As Filter
y = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To y
    Columns(i).Interior.Pattern = xlNone
    On Error GoTo e:
    If ActiveSheet.AutoFilter.FilterMode Then
        Set x = ActiveSheet.AutoFilter.Filters(i)
            If x.On Then
                Columns(i).Interior.Color = RGB(87, 240, 26)
            End If
    End If
Next
e:
End Sub
только срабатывать будет при перевыборе выделения.
поставить пробел между текстом и цифрой с определённой буквой, в конце теста иногда встречаются прикреплённые цифры, их нужно отделить
 
Вроде и формулами получается похоже
Код
=ПОДСТАВИТЬ(E18;ПСТР(E18;ЕСЛИОШИБКА(ПОИСК("х";E18)-4;ПОИСК("x";E18)-2);1);ПСТР(E18;ЕСЛИОШИБКА(ПОИСК("х";E18)-4;ПОИСК("x";E18)-2);1)&" ")
Сохранение книги с новым именем взятым из названия листов книги.
 
Как вариант сборки нового имени файла через поиск минимальной и максимальной даты в именах листов:
Код
Dim arr()
x = ThisWorkbook.Sheets.Count
For i = 1 To x
    If Sheets(i).Visible = 0 Or Sheets(i).Visible = 2 _
    Or Sheets(i).Name = "Исходная форма" Then
        x = x - 1
    Else
        ReDim Preserve arr(x - 1)
        arr(k) = CLng(DateValue(Left(Sheets(i).Name, 8)))
        k = k + 1
    End If
Next
y = Format(Application.Min(arr), "DD-MM-YYYY")
Z = Format(Application.Max(arr), "DD-MM-YYYY")
NewName = ActiveWorkbook.ActiveSheet.[a2] & "_" & y & "_" & Z & ".xlsb"
Выделение ячеек после наступления даты и если соседняя ячейка не заполнена
 
Полагаю что так:
Код
=И($A1<=СЕГОДНЯ();$C1="")
Как в именованную ячейку записывать название бренда
 
Ну если правильно понял то наверно так:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("B4:U39")) Is Nothing Then
    Cells(1, 2) = Cells(4, Target.Column)
End If
End Sub
в модуль листа ПриростСумм
Взять свободную таблицу и поделить на маленькие по значениям в ячейке
 
Возможно так:
Код
Sub t()

    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("B2:B8"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("A1:B8")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
x = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
For i = 2 To x
    If Sheets("Лист1").Cells(i, 2) <> Sheets("Лист1").Cells(i - 1, 2) Then
        Worksheets.Add after:=ActiveSheet
        ActiveSheet.Name = Sheets("Лист1").Cells(i, 2)
        k = 1
        Cells(k, 1) = Sheets("Лист1").Cells(i, 1)
    Else
        k = k + 1
        Cells(k, 1) = Sheets("Лист1").Cells(i, 1)
    End If
Next
Sheets("Лист1").Select
End Sub


Вывести список номеров товаров, где есть примечания, вывести список по отношению к нумерации товаров по столбцу G
 
Возможно так:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("F:F")) Is Nothing Then
    For Each cell In Range("F1:F100")
        If cell.Comment Is Nothing Then
            GoTo n
        Else
            If cell.Offset(1, 0) = "" And cell.Offset(0, 1) <> " " Then
                x = x & cell.Offset(0, 1) & ", "
            Else
                If cell.Offset(1, 0) <> "" And cell.Offset(0, 1) = " " Then
                    GoTo n
                Else
                    x = x & cell.Offset(1, 1) & ", "
        End If
            End If
                End If
n:
    Next
    x = Left(x, Len(x) - 2)
    MsgBox "Номера товаров с примечаниями: " & x
End If
End Sub
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
Цитата
Домкрат написал:
то можно сообщить, что нет примечаний????
Да. Для варианта при полном отсутствии примечаний, добавить сюда Else:
Код
    If x <> "" Then
    MsgBox "Ячейка содержит примечание строки № " & x
    Else
    MsgBox "Нету примечаний"
    End If
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
Дополнил:
Код
On Error Resume Next
Только я столбец для поиска комментов сменил на G чтобы было видно что макрос работает.
Изменено: GRIM - 16 Окт 2019 13:16:43
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
Тогда просто вот так в модуль:
Код
 Sub t()
    For Each cell In Range("F1:F100")
        If cell.Comment Is Nothing Then
        Else
            x = x & cell.Row & ", "
        End If
    Next
    x = Left(x, Len(x) - 2)
    MsgBox "Ячейка содержит примечание строки № " & x
End Sub
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
Если верно вставили код, то он сам запускается при выделении любой ячейки в столбце F.
см. файл
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
На какой строке ошибка?
В модуль листа вставили?
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
Может так?
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("F:F")) Is Nothing Then
    For Each cell In Range("F1:F100")
        If cell.Comment Is Nothing Then
        Else
            x = x & cell.Row & ", "
        End If
    Next
    x = Left(x, Len(x) - 2)
    MsgBox "Ячейка содержит примечание строки № " & x
End If
End Sub
копирование заголовки строк после поиска ячейки
 
И сам макрос примерно вот так будет выглядеть:
Код
Sub t()
s = 3
r = 4
x = Sheets("График").Cells(Rows.Count, 2).End(xlUp).Row
y = Sheets("График").Cells(4, Columns.Count).End(xlToLeft).Column
Z = Sheets("График").Cells(3, 3).MergeArea.Cells.Count
zz = (y - 2) / Z
For i = 1 To zz
    For ii = 5 To x
        If Sheets("График").Cells(ii, 1) <> "" Then
            brig = Sheets("График").Cells(ii, 1)
        End If
        For iii = s To Z + 2
            If Sheets("График").Cells(ii, iii) = "О" Then
                Sheets("Отчет").Cells(r, 7) = brig
                Sheets("Отчет").Cells(r, 8) = Sheets("График").Cells(ii, 2)
                Sheets("Отчет").Cells(r, 9) = "Отгул"
                Sheets("Отчет").Cells(r, 11) = Sheets("График").Cells(4, iii)
                r = r + 1
            End If
            If Sheets("График").Cells(ii, iii) = "П" Then
                Sheets("Отчет").Cells(r, 7) = brig
                Sheets("Отчет").Cells(r, 8) = Sheets("График").Cells(ii, 2)
                Sheets("Отчет").Cells(r, 9) = "Прогул"
                Sheets("Отчет").Cells(r, 11) = Sheets("График").Cells(4, iii)
                r = r + 1
            End If
        Next
    Next
    s = s + Z
    Z = Z + Z
    r = r + 1
Next
End Sub
Добавление чекбокса (checkbox) по макросу, Макрос на добавление чекбоксов в выделенный диапазон
 
Может стоит в эту сторону посмотреть?
Пометка элементов списка
Рассчитать сумму для отрасли за исключением нескольких статусов
 
Полагаю что вот так:
Код
=СУММЕСЛИМН(F4:F8;O4:O8;G10;C4:C8;"<>Возврат";C4:C8;"<>Отказ")
Страницы: 1 2 3 4 5 6 7 След.
Наверх