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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 134 След.
Действие при нажатии на кнопку "Отмена" и проверка, что вводимое значение "не пусто", в InputBox в ходе выполнения макроса
 
Код
Do
    str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
    
    If str2 = False Then
        'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
        MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
        Exit Sub
    End If
    
    If str2 <> "" Then Exit Do
    MsgBox "такое название необходимо ввести", vbCritical, "Информационное сообщение"
Loop
Объединение строк в одну по уникальным значениям в столбце, Объеденение дубликатов в столбце, с последующим сопоставлением строк
 
Код
Исходник!P2:Y35      =ЕСЛИ($A3<>"";ЕСЛИ(ЕПУСТО(E2);"";E2);ЕСЛИ(E2="";ЕСЛИ(ЕПУСТО(P3);"";P3);E2))
Итог!A2:D6           =ВПР(СТРОКА(1:1);Исходник!$A:$Y;СТОЛБЕЦ();0)
Итог!E2:N6           =ВПР(СТРОКА(1:1);Исходник!$A:$Y;СТОЛБЕЦ()+11;0)
Постановка макроса в очередь срабатывания при параллельном запуске макросов в двух разных сессиях
 
Цитата
написал:
часть кода, которая Проверяла бы, работает ли в настоящий момент при этом другой макрос
Как вариант, в другом макросе создавать текстовый файл, по которому первый макрос будет понимать, что макрос работает/завершил работу.
Изменено: МатросНаЗебре - 17.01.2022 12:21:03
Действие при нажатии на кнопку "Отмена" и проверка, что вводимое значение "не пусто", в InputBox в ходе выполнения макроса
 
Код
Do
    str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
    If str2 <> "" Then Exit Do
    MsgBox "такое название необходимо ввести", vbCritical, "Информационное сообщение"
    If str2 = False Then
    'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
    MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
    Exit Sub
    End If
Loop
Поиск координаты по двум критериям, Найти по квоте и по факту нужный балл
 
Цитата
написал:
функция СЧЕТ в конце формулы
Определяет количество столбцов в строке, в которой идёт поиск.
Поиск координаты по двум критериям, Найти по квоте и по факту нужный балл
 
Код
=ИНДЕКС(C4:Q4;ПОИСКПОЗ(I29;СМЕЩ($B$4;ПОИСКПОЗ($I$28;$B$5:$B$19;0);0;1;1+1*СЧЁТ($B$4:$Q$4));-1))
Применить макрос ко всем файлам папки
 
Код
Option Explicit

Public fso As Object

Sub FixFiles()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim arrFiles As Variant
    arrFiles = ShowFileDialog()
    If IsEmpty(arrFiles) Then Exit Sub
    Dim wb As Workbook
    Dim vFile As Variant
    For Each vFile In arrFiles
        If fso.GetExtensionName(vFile) = "csv" Then
            FixCSVFile vFile
        Else
            Set wb = Workbooks.Open(vFile)
            FixFile wb
            wb.Close True
        End If
    Next
End Sub

Sub FixCSVFile(ByVal sFull As String)
    Dim txt As String
    With fso.OpenTextFile(sFull, 1)
        txt = .ReadAll
        .Close
    End With
    
    Dim v As Variant
    For Each v In Array("=", """")
        txt = Replace(txt, v, "")
    Next

    With fso.OpenTextFile(sFull, 2)
        .Write txt
        .Close
    End With
End Sub
 
Sub FixFile(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        FixSheet sh
    Next
End Sub
 
Sub FixSheet(sh As Worksheet)
    With sh.UsedRange
        .NumberFormat = "@"
        Dim arr As Variant
        arr = .Value
        .Value = arr
        .NumberFormat = "General"
    End With
End Sub
 
Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.csv", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
    End With
    ShowFileDialog = arr
End Function
Множественные совпадения ВПР
 
N2:N17    
Код
=ЕСЛИОШИБКА(ВПР(H2;H3:N$18;7;0);СЧЁТЕСЛИМН($H$1:$H$17;H2)+1)-1
В L2 ввести формулу массива (Ctrl+Shift+Enter) и протянуть
Код
=ИНДЕКС($I$1:$I$17;СУММ((K2=$H$1:$H$17)*(СЧЁТЕСЛИМН($K$1:K2;K2)=$N$1:$N$17)*СТРОКА($H$1:$H$17)))
Изменено: МатросНаЗебре - 17.01.2022 10:11:54
Выделение ячейки цветом при повторе значения
 
Пишу в личку.
Не претендую, заказ свободен.
Изменено: МатросНаЗебре - 17.01.2022 17:34:45
Макрос: удаление строк на другом листе по условию (без совпадения - удалить)
 
Код
Option Explicit
Dim wbOut As Workbook
Dim dicID As Object
    
Sub DelRows()
    Dim wbFrom As Workbook
    Set wbFrom = ActiveWorkbook
    
    Set dicID = GetDicID(wbFrom.Sheets("Products"))
    
    Set wbOut = Workbooks.Add(1)
    
    Dim sheetName As Variant
    Dim sh As Worksheet
    For Each sheetName In Array("ProductOptions", "ProductOptionValues")
        On Error Resume Next
        Set sh = wbFrom.Sheets(sheetName)
        On Error GoTo 0
        If Not sh Is Nothing Then
            CopySheet sh
            Set sh = Nothing
        End If
    Next
    
    FinalizeWbOut wbOut
End Sub

Private Sub FinalizeWbOut(wbOut As Workbook)
    With wbOut
        If .Sheets.Count > 1 Then
            Application.DisplayAlerts = False
            .Sheets(1).Delete
            Application.DisplayAlerts = True
        End If
        
        .Saved = True
    End With
End Sub

Private Sub CopySheet(sh As Worksheet)
    sh.Copy After:=wbOut.Sheets(wbOut.Sheets.Count)
    
    With ActiveSheet
        Dim arr As Variant
        Dim orr As Variant
        Dim rUsedRange As Range
        Set rUsedRange = .UsedRange
        arr = rUsedRange
        ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        
        Dim x As Integer
        Dim y As Long
        Dim u As Long
        For y = 1 To UBound(arr, 1)
            If dicID.Exists(arr(y, 1)) Then
                u = u + 1
                For x = 1 To UBound(arr, 2)
                    orr(u, x) = arr(y, x)
                Next
            End If
        Next
        Erase arr
            
        .Cells.ClearContents
        rUsedRange = orr
    End With
End Sub

Private Function GetDicID(sh) As Object
    Dim arr As Variant
    With sh
        arr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 2))
    End With
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(arr, 1)
        dic.Item(arr(y, 1)) = 0
    Next
    
    Set GetDicID = dic
End Function
I suppose I didn't screwed plans about realization of that TR.
Авто ввод остатка при вводе товара, для учета инвентаря
 
Код
=ЕСЛИОШИБКА(СМЕЩ($G$1;МАКС((B8=$B$1:B7)*СТРОКА($B$1:B7))-1;0);0)
Вводить как формулу массива Ctrl+Shift+Enter.
Пример лучше приводить в формате xls*
Извлечь из текста ИНН и КПП
 
Код
=ПСТР(RC1;НАЙТИ(R1C;RC1)+5;НАЙТИ(СИМВОЛ(10);RC1;НАЙТИ(R1C;RC1))-НАЙТИ(R1C;RC1)-5)
Распределить номера платежей по комплектам
 
Код
F2:F9        =ПСТР(СЦЕПИТЬ(I11;J11;K11;L11;M11);2;10000)
G2:G9        =СУММ($D$1:$D2)
I2:M9        =ЕСЛИ(СТОЛБЕЦ()-СТОЛБЕЦ($H:$H)<=$G2-$G1;МАКС($H$1:$M1;$H2:H2)+1;"")
I11:M18      =ЕСЛИ(I2="";"";","&ИНДЕКС($A$2:$A$19;I2))
ВПР + СУММ, Суммировать данные найденные по впр
 
Код
=СУММ(($B24='Норма. Газ счетчик'!$F$3:$F$10)*(D$1='Норма. Газ счетчик'!$J$1:$U$1)*'Норма. Газ счетчик'!$J$3:$U$10)
Вводите как формулу массива Ctrl+Shift+Enter
Найти числа в ячейках с числами и текстом
 
Ну или вариант попроще обычной формулой )
Код
=ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");1;1));0)+ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");2;1));0)+ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");3;1));0)+ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");4;1));0)
Сортировка/фильтрация ячеек вне умной таблицы
 
Код
Option Explicit

Const EXTRA_COLUMNS_COUNT = 2
Const SORT_COLUMN_INDEX = 2

Sub SortTableExtraRange()
    Dim tb As ListObject
    Set tb = GetListObject(ActiveCell)
    If Not tb Is Nothing Then
        Dim tb_Columns_Count As Long
        tb_Columns_Count = tb.DataBodyRange.Columns.Count
        Dim rSort As Range
        Set rSort = tb.DataBodyRange.Resize(, tb_Columns_Count + EXTRA_COLUMNS_COUNT)
        
        Application.ScreenUpdating = False
        
        SortRange rSort
        RestoreListObject tb, tb_Columns_Count
        
        Application.ScreenUpdating = True
        
    End If
End Sub

Sub RestoreListObject(tb As ListObject, tb_Columns_Count As Long)
    tb.Resize tb.Range.Resize(, tb_Columns_Count)
End Sub

Sub SortRange(rSort As Range)
    Dim arr As Variant
    arr = rSort
    
    Dim rn As Range
    Set rn = Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
    rn.Value = arr
    
    With rn.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rn.Columns(SORT_COLUMN_INDEX), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange rn
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    arr = rn
    rn.Parent.Parent.Close False
    rSort = arr
End Sub

Function GetListObject(cl As Range) As ListObject
    Dim tb As ListObject
    For Each tb In cl.Parent.ListObjects
        If Not Intersect(tb.Range, cl) Is Nothing Then
            Set GetListObject = tb
            Exit Function
        End If
    Next
End Function
Применить макрос ко всем файлам папки
 
Код
Option Explicit

Sub FixFiles()
    Dim arrFiles As Variant
    arrFiles = ShowFileDialog()
    If IsEmpty(arrFiles) Then Exit Sub
    Dim wb As Workbook
    Dim vFile As Variant
    For Each vFile In arrFiles
        Set wb = Workbooks.Open(vFile)
        FixFile wb
        wb.Close True
    Next
End Sub

Sub FixFile(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        FixSheet sh
    Next
End Sub

Sub FixSheet(sh As Worksheet)
    With sh.UsedRange
        .NumberFormat = "@"
        Dim arr As Variant
        arr = .Value
        .Value = arr
        .NumberFormat = "General"
    End With
End Sub

Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
    End With
    ShowFileDialog = arr
End Function
Совместить два макроса:удаление дубликатов в одном столбце и сбор данных из другого столбца через запятую
 
Код
Option Explicit

Sub FlatActiveSheet()
    FlatSheet ActiveSheet
End Sub

Sub FlatSheet(sh As Worksheet)
    sh.Copy
    
    With ActiveSheet
        Dim arr As Variant
        Dim orr As Variant
        arr = .UsedRange
        ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim y As Long
        For y = 1 To UBound(arr, 1)
            If Not dic.Exists(CStr(Trim(arr(y, 4)))) Then
                Set dic.Item(CStr(Trim(arr(y, 4)))) = CreateObject("Scripting.Dictionary")
            End If
            dic.Item(CStr(Trim(arr(y, 4)))).Item(CStr(Trim(arr(y, 3)))) = 0
        Next
        
        Dim u As Long
        Dim x As Integer
        For y = 1 To UBound(arr, 1)
            If dic.Exists(CStr(Trim(arr(y, 4)))) Then
                u = u + 1
                For x = 1 To UBound(arr, 2)
                    orr(u, x) = arr(y, x)
                Next
                orr(u, 3) = Join(dic.Item(CStr(Trim(arr(y, 4)))).Keys(), ",")
                dic.Remove (CStr(Trim(arr(y, 4))))
            End If
        Next
        
        .Cells.ClearContents
        .Cells(1, 1).Resize(UBound(orr, 1), UBound(orr, 2)).Value = orr
    End With
End Sub

Вариант названия темы
Удаление дубликатов в одном столбце, сбор данных из другого столбца через запятую.
Изменено: МатросНаЗебре - 13.01.2022 17:36:09
Удалить апострофы и лишние знаки препинания по всему листу
 
Код
Sub FixActiveSheet()
    FixSheet ActiveSheet
End Sub

Sub FixSheet(sh As Worksheet)
    With sh.UsedRange
        .NumberFormat = "@"
        Dim arr As Variant
        arr = .Value
        .Value = arr
        .NumberFormat = "General"
    End With
End Sub

Фильтрация по нескольким столбцам
 
Может так
Фильтрация данных с помощью автофильтра (microsoft.com)
Поиск разных значений по одному признаку, По одному столбику с одинаковым значением найти разные значения по другому столбику
 
Код
=ВПР(A3;$A1:C2;3;0)<>C3
Фильтрация по нескольким столбцам
 
И чем #2 не подошёл?
Фильтр по столбцу L содержит Токар.
Фильтрация по нескольким столбцам
 
Включите фильтр (Ctrl+Shift+L)
И отфильтруйте по столбцу 4.
Фильтрация по нескольким столбцам
 
Код
L2    =D2&E2&F2&G2&H2&I2&J2&K2
И фильтровать по столбцу L.
Макрос - удаление строк дубликатов по 2 значениям
 
Код
Sub Макрос1()
    ActiveSheet.Columns("C:C").Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(3, 4), Header:=xlYes
End Sub
Подкорректировать макрос объединения текста из разных ячеек
 
Ещё вариант.
Код
Sub Соединить_через_запятую()
  Const sDELIM As String = ","     'символ-разделитель
  Dim rCell As Range
  If TypeName(Selection) <> "Range" Then Exit Sub   'если выделены не ячейки - выходим
    Dim arr As Variant
    ReDim arr(1 To Selection.Cells.Count)
  With Selection
      Dim i As Long
      For Each rCell In .Cells
          i = i + 1
          arr(i) = rCell.Text
      Next rCell
      .ClearContents
      .Cells(1, 1).Value = Join(arr, sDELIM)
  End With
End Sub
Подкорректировать макрос объединения текста из разных ячеек
 
Код
 Const sDELIM As String = ""     'символ-разделитель
Макрос на скрытие столбцов по нескольким выпадающим спискам, Создание скрытых столбцов
 
Вы только один макрос вставили?
Макрос на скрытие столбцов по нескольким выпадающим спискам, Создание скрытых столбцов
 
Это в модуль листа "План по менеджерам"
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C1:C2")) Is Nothing Then FilterColumn
End Sub
Это вставить в стандартный модуль и запустить один раз.
Код
Sub Макрос1()
    With Range("C1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Наружка,Радио,Телевидение,Итого"
        .IgnoreBlank = False: .InCellDropdown = True: .InputTitle = "": .ErrorTitle = "": .InputMessage = "": .ErrorMessage = "": .ShowInput = True: .ShowError = True
        .Parent.Value = "Наружка"
    End With
    With Range("C2").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Январь,Февраль,Март,Апрель,Май,Июнь,Июль,Август,Сентябрь,Октябрь,Ноябрь,Декабрь"
        .IgnoreBlank = False: .InCellDropdown = True: .InputTitle = "": .ErrorTitle = "": .InputMessage = "": .ErrorMessage = "": .ShowInput = True: .ShowError = True
        .Parent.Value = "Январь"
    End With
End Sub
Это вставить в стандартный модуль.
Код
Sub FilterColumn()
    Dim showColumn As Boolean
    Dim x As Long
    For x = 5 To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
        showColumn = False
        If Cells(3, x).Value = Range("C2").Value Then
            If InStr(Cells(1, x).MergeArea.Cells(1, 1).Value, Range("C1").Value) > 0 Then
                showColumn = True
            End If
        End If
        Columns(x).Hidden = Not showColumn
    Next
End Sub
Меняйте значения в ячейках C1 и C2.
Изменено: МатросНаЗебре - 13.01.2022 14:33:22
Как править экселевский файл вместе?
 
Совместная работа с документами Excel (lumpics.ru)
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 134 След.
Наверх