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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 302 След.
Сумма модулей, как посчитать сумму модулей в одной ячейке
 
Вариант вывода суммы модулей в ячейку с помощью пользовательской формы. :D
Код
Option Explicit
'v2
Private Sub CommandButton1_Click()
    ActiveCell.Formula = ConnectText
End Sub

Private Function ConnectText() As String
    Dim cb As Object, ss As String, iCount As Long
    ss = "="
    For Each cb In GetControlColection("TextBox")
        iCount = iCount + 1
        If IsNumeric(cb.Value) Then
            If iCount Mod 2 = 1 Then
                ss = ss & "+ABS("
            End If
            If cb.Value >= 0 Then
                ss = ss & "+" & cb.Value
            Else
                ss = ss & cb.Value
            End If
            If iCount Mod 2 <> 1 Then
                ss = ss & ")"
            End If
        End If
    Next
    ConnectText = ss
End Function

Private Function GetControlColection(sTypeName As String) As Collection
    Dim col As New Collection
    Dim cb As Control
    For Each cb In Me.Controls
        If TypeName(cb) = sTypeName Then
            col.Add cb
        End If
    Next
    Set GetControlColection = col
End Function

Изменено: МатросНаЗебре - 06.03.2026 16:35:12
Сумма модулей, как посчитать сумму модулей в одной ячейке
 
Код
=1+СУММ((2-2);(4-4);(10-10))-15
Или так. Так ещё абсурднее :D  
Сумма модулей, как посчитать сумму модулей в одной ячейке
 
Цитата
написал:
как посчитать сумму диапазонов в 1 ячейке
Например, вставить формулу
Код
=1-2+2-4+4-10+10-15

для модулей
Код
=ABS(1-2)+ABS(2-4)+ABS(4-10)+ABS(10-15)
Изменено: МатросНаЗебре - 06.03.2026 14:22:42
Сумма модулей, как посчитать сумму модулей в одной ячейке
 
Цитата
написал:
1-2, 2-4,4-10,10-15 в сумме это 14
1-2+2-4+4-10+10-15=-14
Это минус 14.
Поиск значения и вставка текса в ячейку рядом с ним
 
Скорее всего, в данном случае это можно перевести, как "индивид не справился с копированием текста".
Изменено: МатросНаЗебре - 06.03.2026 13:07:06 (Прикрепил файл.)
Поиск значения и вставка текса в ячейку рядом с ним
 
Код
Option Explicit
Private Const sFIND = "NC"
Private Const sPRINT = "LIBER"

Sub NC_LIBER()
    NC_LIBER_sheetJob ActiveSheet
End Sub

Private Sub NC_LIBER_sheetJob(sh As Worksheet)
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim nc As Range, cAfter As Range, firstAddress As String
    Do
        On Error Resume Next
        If cAfter Is Nothing Then
            Set nc = sh.UsedRange.Find(What:=sFIND)
            firstAddress = nc.Address(0, 0, xlA1)
        Else
            Set nc = sh.UsedRange.Find(What:=sFIND, After:=cAfter)
            If firstAddress = nc.Address(0, 0, xlA1) Then Exit Do
        End If
        On Error GoTo 0
        If nc Is Nothing Then Exit Do
        NC_LIBER_cellJob nc.Cells(1, 2)
        
        Set cAfter = nc
        DoEvents
    Loop
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub

Private Sub NC_LIBER_cellJob(li As Range)
    If li.Value <> sPRINT Then
        li.Value = sPRINT
        li.Font.Color = RGB(255, 0, 0)
    End If
End Sub
Объединение нескольких макросов в один, Есть три макроса, которые нужно объединить в один, без потери функций и дубляжа.
 
Если ввод выполнять через лист, то первый макрос можно заменить одной строкой.
Код
Sub RegisterPatient()
    Range("A1:I1").Copy Cells(Rows.Count, 1).End(xlUp).Cells(2, 1)
End Sub
Объединение нескольких макросов в один, Есть три макроса, которые нужно объединить в один, без потери функций и дубляжа.
 
Добавил значения по умолчанию в InputBox-ы по активной строке.
Код
Public Function AC(What As String) As Variant
    Dim cf As Range
    On Error Resume Next
    Set cf = ActiveSheet.Cells.Find(What:=What, LookAt:=xlPart)
    On Error GoTo 0
    If Not cf Is Nothing Then
        AC = Intersect(ActiveCell.EntireRow, cf.EntireColumn)
    End If
End Function
Переход между листами с условиями: видимый и не видимый лист и один активный лист
 
Такой вариант.
Выгрузка Excel(2016) по заданным параметрам., Выгрузка Excel(2016) по заданным параметрам, тем который задаём по потребность.
 
Цитата
написал:
For Each colName In Array("Приоритет", "Осталось на выполнение", "Категории")это?
Верно. Знания приобретены, уже можно пробовать свои силы на этом форуме в качестве помогатора )
Выгрузка Excel(2016) по заданным параметрам., Выгрузка Excel(2016) по заданным параметрам, тем который задаём по потребность.
 
Цитата
написал:
Можно вас попросить прокомментировать все действия.
Код
Option Explicit 'В модуле обязательно объявлять переменные. Да, да, оказывается в VBA можно не объявлять переменные.
 
Sub Таблица_поумничай()     'Название макроса
    CloseEmptyWb    'Вызов вспомогательной процедуры для закрытия "пустых" книг.
    ActiveSheet.Copy    'Копируем активный лист в новую книгу.
     
    Dim xx As Long, colName As Variant
    For xx = ActiveSheet.UsedRange.Columns.Count To ActiveSheet.UsedRange.Column Step -1    'Перебираем столбцы с последнего до первого
        For Each colName In Array("Приоритет", "Осталось на выполнение", "Категории")   'Перебираем названия столбцов для удаления
            If Cells(1, xx).Value = colName Then    'Если значение в первой строке равно названию для удаления
                Columns(xx).EntireColumn.Delete     'удаляем весь столбец
            End If
        Next
    Next
    ActiveSheet.Shapes(1).Delete    'Удаляем кнопку, которая скопировалась вместе с листом.
    ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Таблица1"   'Создаём умную таблицу.
    ActiveSheet.ListObjects(1).TableStyle = "TableStyleLight13" 'Задаём стиль умной таблицы
    ActiveSheet.ListObjects(1).ShowTotals = True    'Отображаем строку итогов.
    ActiveSheet.ListObjects(1).ListColumns("Статус").TotalsCalculation = xlTotalsCalculationCount   'В строке итогов в столбце Статус ставим формулу подсчёта значений
    ActiveSheet.ListObjects(1).ListColumns("Изменена").TotalsCalculation = xlTotalsCalculationNone  'В строке итогов в столбце Изменена ставим формулу подсчёта значений
    ActiveSheet.ListObjects(1).Range.Select 'Выделяем диапазон умной таблицы.
End Sub
 
Private Sub CloseEmptyWb() 'Вспомогательная процедура для закрытия "пустых" книг.
    Dim wb As Workbook
    For Each wb In Application.Workbooks    'Перебираем книги в приложении
        If wb.Path = "" Then wb.Close False 'Если книга не была ни разу сохранена, закрыть без сохранения.
    Next
End Sub
Цитата
написал:
Я хотел бы добавить ещё действие, что бы убрать столбец "Исполнители".
Напишите, нашли ли, куда внести изменения, интересно всё-таки.
Переход между листами с условиями: видимый и не видимый лист и один активный лист
 
Цитата
написал:
если я создам Отчёт2. стр. (1), Отчёт2. стр. (2), Отчёт3. стр. (1), Отчёт3. стр. (2), и т.д. но где мне внести изменения
В моём макросе список создаётся автоматически. Рукам изменения можно не вносить.
Переход между листами с условиями: видимый и не видимый лист и один активный лист
 
Цитата
написал:
или что-то я не так делаю?
Этот вариант. Что-то не так делаете, надо делать что-то так.
Поиск ближайшего меньшего числа в списке, соответствующего поисковому значению
 
Код
=ИНДЕКС(СМЕЩ(B12;ПОИСКПОЗ(A4;A13:A20;0);0;СЧЁТЕСЛИМН(A13:A20;A4);1);ПОИСКПОЗ(B4;СМЕЩ(B12;ПОИСКПОЗ(A4;A13:A20;0);0;СЧЁТЕСЛИМН(A13:A20;A4);1);1))
Несколько архаичный вариант)
Переход между листами с условиями: видимый и не видимый лист и один активный лист
 
Добавил формирование листа Содержание и ещё по мелочи.
Код
Public Sub FormToc(sh As Worksheet)
    Const skip = "Главная Содержание Результаты"
    Dim aSkip As Variant
    aSkip = Split(skip, " ")
    
    Dim nn As Long
    nn = ThisWorkbook.Worksheets.Count - (UBound(aSkip) + 1)
    nn = WorksheetFunction.RoundUp(Sqr(nn), 0)
    
    Dim arr As Variant, xa As Long, ya As Long
    ReDim arr(1 To nn, 1 To nn)
    ya = 1
    
    Dim iSh As Worksheet
    For Each iSh In ThisWorkbook.Worksheets
        If InStr(skip, iSh.Name) = 0 Then
            xa = xa + 1
            If xa > UBound(arr, 2) Then
                xa = 1
                ya = ya + 1
            End If
            arr(ya, xa) = iSh.Name
        End If
    Next
    
    Dim rr As Range
    Set rr = sh.Range("B2").Resize(UBound(arr, 1), UBound(arr, 2))
    rr.Value = arr
    rr.EntireColumn.AutoFit
End Sub
Выгрузка Excel(2016) по заданным параметрам., Выгрузка Excel(2016) по заданным параметрам, тем который задаём по потребность.
 
Скажу словами великого Лёвы:
- А это что, абориген хренов?!  :D
Цитата
написал:
ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Таблица1"
Переход между листами с условиями: видимый и не видимый лист и один активный лист
 
Исправил макросы на листах, кроме Содержания.
Переход между листами с условиями: видимый и не видимый лист и один активный лист
 
Так?
Код
Private Sub Следующий_Click()
    Worksheets("Отчёт1. стр. (2)").Visible = True
    Worksheets("Отчёт1. стр. (2)").Activate
    Me.Visible = False
End Sub
Выгрузка Excel(2016) по заданным параметрам., Выгрузка Excel(2016) по заданным параметрам, тем который задаём по потребность.
 
Цитата
написал:
Так же не форматируется в умную таблицу.
Случайно умную со сводной таблицей не путаете?
Выгрузка Excel(2016) по заданным параметрам., Выгрузка Excel(2016) по заданным параметрам, тем который задаём по потребность.
 
Цитата
написал:
В данном макросе не отформатировано под дату колонка "F" и "J"
Верно, столбцы F и J дополнительно не форматируются.
А должны? Пересмотрел сообщение #1, там ни слова про эту часть.
Реализация выпадающих списков по условиям, Как в выпадающем списке запретить выбирать один и тот же кабинет в одну и ту же смену и разрешить в разные смены
 
Думаю, в столбце C формула должна быть
Код
=C1--(СЧЁТЕСЛИМН(Double[Итог];[@[Все_каб]];Double[Смена];C$1)=0)*(СЧЁТЕСЛИМН(Double[Итог];[@[Все_каб]])<2)*(СЧЁТЕСЛИМН(Minus_cab;[@[Все_каб]])=0)*(СЧЁТЕСЛИМН(withdraw_cab;[@[Все_каб]])=0)
Реализация выпадающих списков по условиям, Как в выпадающем списке запретить выбирать один и тот же кабинет в одну и ту же смену и разрешить в разные смены
 
Достаточно в столбце B добавить в формулу ограничение по этим диапазонам.
Код
=B1--(СЧЁТЕСЛИМН(Double[Корр];[@[Все_каб]])<2)*(СЧЁТЕСЛИМН(Minus_cab;[@[Все_каб]])=0)*(СЧЁТЕСЛИМН(withdraw_cab;[@[Все_каб]])=0)
В столбцы B:D надо добавить это ограничение.
Код
*(СЧЁТЕСЛИМН(Minus_cab;[@[Все_каб]])=0)*(СЧЁТЕСЛИМН(withdraw_cab;[@[Все_каб]])=0)
Изменено: МатросНаЗебре - 03.03.2026 14:50:59
Выгрузка Excel(2016) по заданным параметрам., Выгрузка Excel(2016) по заданным параметрам, тем который задаём по потребность.
 
Код
Option Explicit

Sub Таблица_поумничай()
    CloseEmptyWb
    ActiveSheet.Copy
    
    Dim xx As Long, colName As Variant
    For xx = ActiveSheet.UsedRange.Columns.Count To ActiveSheet.UsedRange.Column Step -1
        For Each colName In Array("Приоритет", "Осталось на выполнение", "Категории")
            If Cells(1, xx).Value = colName Then
                Columns(xx).EntireColumn.Delete
            End If
        Next
    Next
    ActiveSheet.Shapes(1).Delete
    ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Таблица1"
    ActiveSheet.ListObjects(1).TableStyle = "TableStyleLight13"
    ActiveSheet.ListObjects(1).ShowTotals = True
    ActiveSheet.ListObjects(1).ListColumns("Статус").TotalsCalculation = xlTotalsCalculationCount
    ActiveSheet.ListObjects(1).ListColumns("Изменена").TotalsCalculation = xlTotalsCalculationNone
    ActiveSheet.ListObjects(1).Range.Select
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Реализация выпадающих списков по условиям, Как в выпадающем списке запретить выбирать один и тот же кабинет в одну и ту же смену и разрешить в разные смены
 
На листе Все_кабинеты в столбцах B:D.
Реализация выпадающих списков по условиям, Как в выпадающем списке запретить выбирать один и тот же кабинет в одну и ту же смену и разрешить в разные смены
 
Цитата
написал:
А в каком столбце у Вас проверка, что кабинет уже задействован стоит? Я так понимаю, что проверка идет по столбцу C.
Верно, по столбцу C.
Цитата
написал:
Но она должна быть по столбцу D (итог)
Я не возражаю :)
Цитата
написал:
Потому, как сейчас можно снова выбрать 320Д А он уже выбран на скриншоте
Если в столбце С уже выбран 320Д_СВОБ для смены 1, то в выпадающем списке в столбце C для смены 1 320Д_СВОБ не выводится.
Подчёркнутое на скриншоте у меня не воспроизводится.
Баллы по времени трасс по интервалам из другого листа., Необходимо посчитать сумму баллов по времени трассы согласно разбалловке для формирования рейтинга пилота.
 
Код
=5-ЕСЛИОШИБКА(ПОИСКПОЗ(G3;СМЕЩ(Дэшборд!$G$3:$K$3;СТОЛБЕЦ(A1)-1;0);1);0)+(G3=СМЕЩ(Дэшборд!$K$3;СТОЛБЕЦ(A1)-1;0))
Реализация выпадающих списков по условиям, Как в выпадающем списке запретить выбирать один и тот же кабинет в одну и ту же смену и разрешить в разные смены
 
Можно и динамическими.
Реализация выпадающих списков по условиям, Как в выпадающем списке запретить выбирать один и тот же кабинет в одну и ту же смену и разрешить в разные смены
 
В каком-то смысле кабинет это тоже класс  :D  
Фильтрация нескольких столбцов по одному критерию
 
Вариант макросом.
Код
Option Explicit
Private Const FIO_CELL = "B1"
Private Const FIRST_DATA_ROW = 4

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0, xlA1) <> FIO_CELL Then Exit Sub
    
    Dim rr As Range, arr As Variant, ya As Long, xa As Long
    Set rr = Intersect(ActiveSheet.UsedRange, Rows(FIRST_DATA_ROW).Resize(ActiveSheet.UsedRange.Rows.Count))
    
    rr.EntireRow.Hidden = False
    If IsEmpty(Target.Value) Then Exit Sub
    arr = rr.Value
    
    Dim Target_Value As Variant
    Target_Value = Target.Value
    For ya = UBound(arr, 1) To LBound(arr, 1) Step -1
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If InStr(arr(ya, xa), Target_Value) <> 0 Then GoTo skipRow
        Next
        rr.Rows(ya).EntireRow.Hidden = True
skipRow:
    Next
End Sub
Фильтрация нескольких столбцов по одному критерию
 
Вариант формулами с дополнительным столбцом.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 302 След.
Наверх