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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 121 След.
Слова из существующего списка выводить в виде текста.
 
Никакого секрета. Обычная ситуация. Я спасовал, не договорившись о цене.
Изменено: МатросНаЗебре - 23.09.2021 12:50:39 (опечатка)
Слова из существующего списка выводить в виде текста.
 
В стандартный модуль.
Код
Option Explicit

'Для старта.
Sub Start()
    PrintWord GetDirection() + 1
End Sub
'Для смены направления перевода.
Sub ChangeDirection()
    With Sheets("Проверка").Range("E1")
        Application.EnableEvents = False
        If IsEmpty(.Value) Then
            .Value = "eng"
        Else
            .Value = Empty
        End If
        Application.EnableEvents = True
    End With
End Sub
Function GetDirection() As Byte
    Dim direction As Byte
    With Sheets("Проверка").Range("E1")
        If IsEmpty(.Value) Then
            direction = 0
        Else
            direction = 1
        End If
    End With
    GetDirection = direction
End Function

Function GetArr() As Variant
    Dim arr As Variant
    Dim y As Long
    With Sheets("Словарь")
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    GetArr = arr
End Function

Sub PrintWord(ByVal x As Byte)
    Dim arr As Variant
    Dim y As Long
    arr = GetArr()
    If x < 1 Or x > UBound(arr, 2) Then x = 1
    
    With Sheets("Проверка")
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        y = y + 1
        If y > 30 Then Exit Sub
        Dim r As Range
        Set r = .Cells(y, 1)
        Randomize
        y = Rnd() * (UBound(arr, 1) - 1) + 1
        If y < 2 Then y = UBound(arr, 1)
        r.Value = arr(y, x)
        .Select
        Application.EnableEvents = False
        r.Cells(1, 2).Select
        Application.EnableEvents = True
    End With
End Sub
В модуль листа Проверка.
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Column = 2 Then
            If Target.Row <= 30 Then
                If Target.Value <> "" Then
                    Dim arr As Variant
                    arr = GetArr()
                    Dim d As Byte
                    d = GetDirection()
                    Dim s1 As String
                    Dim s2 As String
                    With Cells(Target.Row, Target.Column - 1)
                        s1 = LCase(.Cells(1, 1 + d).Value)
                        s2 = LCase(.Cells(1, 2 - d).Value)
                    End With
                    Dim y As Long
                    Dim b As Boolean
                    b = False
                    For y = 1 To UBound(arr, 1)
                        If LCase(arr(y, 1)) = s1 Then
                            If LCase(arr(y, 2)) = s2 Then
                                b = True
                            End If
                            Exit For
                        End If
                    Next
                    
                    If b Then
                        PrintWord d + 1
                    Else
                        Application.EnableEvents = False
                        Target.Value = Empty
                        Target.Select
                        Application.EnableEvents = True
                    End If
                
                End If
            End If
        End If
    End If
End Sub
Слова из существующего списка выводить в виде текста.
 
Готов взяться за задачу.
Пас.
Изменено: МатросНаЗебре - 22.09.2021 14:04:46
При использовании формулы в источнике выпадающего списка появляется ошибка
 
Вариант с дополнительным столбцом
Код
=Лист2!C2       =ПРАВСИМВ(B2;3)
Формула для выпадающего списка
Код
=СМЕЩ(Лист2!$C$2:$C$1048576;0;0;СЧЁТЗ(Лист2!$C$2:$C$1048576))
Макрос копирующий диапазон в новый лист с сохранением настроек
 
В сообщении #7 нет действий, порядок которых нужно запоминать людям очень далёким от компьютера. Там описаны действия для людей, видимо, очень близким к компьютеру. "Закройте сохранённую книгу".

Ну или
Код
ActiveWorkbook.Close
Изменено: МатросНаЗебре - 22.09.2021 10:38:02
Формирование служебной записки из графика выхода
 
Код
Option Explicit
'Версия 5.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub
 
Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub
 
Function GetArr() As Variant
    Dim sh As Worksheet
    Set sh = Sheets("СВОДКА РЭС-7")
    With sh
        .Select 'Проверка выполняется по выделенным ячейкам
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
         
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
                    e = x
                    Do
                        Select Case arr(y, e)
                        Case " "
                            e = e + 1
                        Case Else
                            e = e - 1
                            Exit Do
                        End Select
                    Loop
                     
                    If Not dic.Exists(arr(y, 2)) Then
    '                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                        Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    Else
    '                    crr = dic.Item(arr(y, 2))
    '                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                    End If
                    crr = Array(arr(y, 5), arr(y, 2), DateValue(arr(yM + 1, x) & " " & arr(yM, 6)), DateValue(arr(yM + 1, e) & " " & arr(yM, 6)))
                    dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                     
    '                ReDim Preserve brr(0 To UBound(brr) + 1)
    '                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    x = e
                End If
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If dic.Count < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(Format(v(2), "dd.mm.yy") & IIf(v(2) = v(3), "", " - " & Format(v(3), "dd.mm.yy")), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function
Изменено: МатросНаЗебре - 22.09.2021 09:14:09
Макрос копирующий диапазон в новый лист с сохранением настроек
 
Вы сообщение #7 прочитали?
Извлечение данных с другого листа смещенных относительно искомого слова по столбцам или по строкам.
 
Код
=ИНДЕКС(Лист1!$D$1:$D$2000;2000-НАИБОЛЬШИЙ((Лист1!$B$1:$B$2000=B6)*(2000-СТРОКА(Лист1!$B$1:$B$2000));СТРОКА(1:1)))
Вводить как формулу массива Ctrl+Shift+Enter.
Как создать структуру в таблице по отступам
 
Код
Sub SelectionGroup()
    Selection.ClearOutline
    Dim y As Long
    For y = Selection.Row To Selection.Row + Selection.Rows.Count - 1
        Rows(y).OutlineLevel = Cells(y, 1).IndentLevel + 1
    Next
End Sub
Запуск макроса в зависимости от значения + цикл
 
Код
Application.Run "'" & ThisWorkbook.Name & "'!'" & curCell.Value    
Можно так. Но так не выполняется проверка значений. Если макроса не будет, будет ошибка.
Запуск макроса в зависимости от значения + цикл
 
Сработало без Run. Куда-то не туда смотрю?
Код
Sub test()
    Dim i As Byte
    For i = 1 To 3
        If Cells(i, 1).Value = "ГГКц" Then ГГКц
    Next
End Sub

Sub ГГКц()
    Debug.Print Now, "ГГКц"
End Sub
Запуск макроса в зависимости от значения + цикл
 
Может так
Код
If curCell.Value = "ГГКц" Then ГГКц
Сохранение элементов VBA-коллекции на лист за один проход., (т.е. без записи каждой отдельной ячейки, а все сразу, оптом)
 
Эту строку
Код
KM.Add KM.Count, CStr(i.Value)
Замените на эту
Код
KM.Item(CStr(i.Value)) = 0

И эту
Код
Range("A1").Resize(KM.Count, 1) = Application.Transpose(KM.Items())

На эту
Код
Range("A1").Resize(KM.Count, 1) = Application.Transpose(KM.Keys())
Изменено: МатросНаЗебре - 21.09.2021 10:03:50
Сохранение элементов VBA-коллекции на лист за один проход., (т.е. без записи каждой отдельной ячейки, а все сразу, оптом)
 
Почитал про коллекции. Соглашусь с замечанием по повторам.
Изменено: МатросНаЗебре - 21.09.2021 09:50:54
Сохранение элементов VBA-коллекции на лист за один проход., (т.е. без записи каждой отдельной ячейки, а все сразу, оптом)
 
У ТС в первом сообщении коллекция наполняется таким образом, что возможны повторы.
Для того, чтобы сохранить эту возможность, сделал выгрузку значений.
Как выгрузить массив на лист без цикла?, по мотивам соседней темы
 
Код
Range("A1").Resize(1,Ubound(arr)-Lbound(arr)+1) = arr
Сохранение элементов VBA-коллекции на лист за один проход., (т.е. без записи каждой отдельной ячейки, а все сразу, оптом)
 
Можно, заменив коллекцию на словарь.
Код
Sub СборкаМатериалов220921()
    Dim KM As Object
    Set KM = CreateObject("Scripting.Dictionary")
    Dim arr As Variant
    Set arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each i In arr
        KM.Add KM.Count, CStr(i.Value)
    Next i
    On Error GoTo 0
     
    Range("A1").Resize(KM.Count, 1) = Application.Transpose(KM.Items())
End Sub
Формирование служебной записки из графика выхода
 
Выделите диапазон на листе СВОДКА РЭС-7. Запустите макрос.
Код
Option Explicit
'Версия 4.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub
 
Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub
 
Function GetArr() As Variant
    Dim sh As Worksheet
    Set sh = Sheets("СВОДКА РЭС-7")
    With sh
        .Select 'Проверка выполняется по выделенным ячейкам
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
         
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
                    e = x
                    Do
                        Select Case arr(y, e)
                        Case " "
                            e = e + 1
                        Case Else
                            e = e - 1
                            Exit Do
                        End Select
                    Loop
                     
                    If Not dic.Exists(arr(y, 2)) Then
    '                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                        Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    Else
    '                    crr = dic.Item(arr(y, 2))
    '                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                    End If
                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                     
    '                ReDim Preserve brr(0 To UBound(brr) + 1)
    '                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    x = e
                End If
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If dic.Count < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(v(2) & IIf(v(2) = v(3), "", " - " & v(3)), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function
Заполнить карточку при вводе номера карточки
 
Вводить надо как формулу массива Ctrl+Shift+Enter.
Сохранить часть листа в отдельный файл
 
Там речь про то, как перенести всё, включая форматирование.

Кнопку удалить можно так:
Код
If ActiveSheet.Shapes.Count > 0 Then ActiveSheet.Shapes(1).Delete
Добавление строк в конце таблицы с комментарием VBA
 
Формулой
Код
=СЧЁТЕСЛИМН(новая!$A:$A;$A:$A;новая!$B:$B;$B:$B;новая!$D:$D;$D:$D;новая!$E:$E;$E:$E;новая!$F:$F;$F:$F;новая!$G:$G;$G:$G)

Код
Макросом

Sub Сравнить()
    Dim y As Long
    Dim r As Range
    
    'Задаём ячейку на листе новая, в которую будем вносить.
    With Sheets("новая")
        Set r = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
    End With
    
    With Sheets("старая") 'На листе старая
        y = .Cells(.Rows.Count, 1).End(xlUp).Row    'ищем номер последней строки
        If y < 3 Then Exit Sub  'Если строк мало, выходим из макроса
        With .Range(.Cells(1, "H"), .Cells(y, "H")) 'в столбец H
            .FormulaR1C1 = "=COUNTIFS(новая!C1,C1,новая!C2,C2,новая!C4,C4,новая!C5,C5,новая!C6,C6,новая!C7,C7)" 'вписываем формулу, считающую, сколько раз встречается строка
            .Calculate  'вычисляем внесённую формулу. На случай, если вычисления отключены.
            Dim arr As Variant
            arr = .Cells    'Результат запоминаем в массив
        End With
         
        Dim brr As Variant
        For y = 2 To UBound(arr, 1) 'Перебираем строки полученного массива
            If arr(y, 1) = 0 Then   'Если значение 0, если строки нет на листе новая
                brr = .Cells(y, 1).Resize(1, 7) 'Запоминаем первые 7 столбцов в массив
                r.Resize(UBound(brr, 1), UBound(brr, 2)) = brr  'В ячейку на листе новая вносим массив.
                r.Cells(1, UBound(brr, 2) + 1).Value = "Удалена"    'Справа дописываем новая.
 
                Set r = r.Cells(2, 1)   'Сдвигаем ячейку, в которую будем вставлять данные.
            End If
        Next
    End With
End Sub

Изменено: МатросНаЗебре - 20.09.2021 17:12:51 (Добавил комментарии)
Сохранить часть листа в отдельный файл
 
Можно посмотреть в теме, созданной сегодня.
Макрос копирующий диапазон в новый лист с сохранением настроек (planetaexcel.ru)

Оставить значения можно так:
Код
Sub OnlyVal()
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(ActiveSheet.UsedRange, Columns("A:F"))
    On Error GoTo 0
    If Not r Is Nothing Then
        Dim arr As Variant
        arr = r
        r = arr
    End If
End Sub
Изменено: МатросНаЗебре - 20.09.2021 15:06:04
Макрос копирующий диапазон в новый лист с сохранением настроек
 
Цитата
Родион Цараков написал:
В момент создания нового файла, excel конфликтует
А точно в момент создания нового файла?
Не в момент сохранения?
Код
Sub SozdatFajl3()
    ActiveSheet.Copy
    Range("S1:XFD1048576").Delete Shift:=xlToLeft
    Range("A1:I1048576").Delete Shift:=xlToLeft
    Rows("46:1048576").Delete Shift:=xlUp
    
    Const sFull = "C:\Users\TsarakovRCh\Documents\Тестирование\Деффектная ведомость\Деффектная ведомость.xlsx"
    On Error Resume Next
    Workbooks("Деффектная ведомость.xlsx").Close False
    On Error GoTo 0
    If Dir(sFull) <> "" Then Kill sFull
    ActiveWorkbook.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Макрос сравнения/вставки. Признак сравнения - фраза первого столбеца обоих листов в книге.
 
Код
Sub ПеренестиРазное()
    Dim y As Long
    Dim u As Long
    Dim v As Variant
    With Sheets("Разное")
        Dim arR As Variant
        Dim brr As Variant
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arR = .Range(.Cells(1, 1), .Cells(y, 1 - (y = 1)))
        For y = 2 To UBound(arR, 1)
            If arR(y, 1) <> "" Then
                For Each v In Array("/", "(", Chr(160))
                    arR(y, 1) = Replace(arR(y, 1), v, " ")
                Next
                arR(y, 1) = Trim(arR(y, 1))
                brr = Split(arR(y, 1), " ")
                u = 0
                On Error Resume Next
                u = WorksheetFunction.Match(brr(0), Sheets("Основной прайс").Columns(1), 0)
                On Error GoTo 0
                If u > 0 Then
                    Sheets("Основной прайс").Rows(u + 1).Insert Shift:=xlDown
                    .Rows(y).Copy Sheets("Основной прайс").Cells(u + 1, 1)
                    Sheets("Основной прайс").Cells(u + 1, 1).EntireRow.Interior.Color = RGB(200, 255, 200)
                End If
            End If
        Next
    End With
End Sub
Макрос копирующий диапазон в новый лист с сохранением настроек
 
Цитата
Родион Цараков написал:
данные должны копироваться на лист без макросов
Надеюсь, это означает, сохранить в файл с раcширением xlsx. А не использовать макрос, без использования макросов )
Код
Sub SozdatFajl2()
    ActiveSheet.Copy
    Range("S1:XFD1048576").Delete Shift:=xlToLeft
    Range("A1:I1048576").Delete Shift:=xlToLeft
    Rows("46:1048576").Delete Shift:=xlUp
    ActiveWorkbook.SaveAs Filename:="C:\Users\TsarakovRCh\Documents\Тестирование\Деффектная ведомость\Деффектная ведомость.xlsx", FileFormat:= xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Сумма с несколькими условиями по разным столбцам
 
Код
=СУММЕСЛИМН($D$2:$D$11;$A$2:$A$11;"яблоко";$B$2:$B$11;"<>122";$B$2:$B$11;"<>128")+СУММЕСЛИМН($D$2:$D$11;$A$2:$A$11;"молоко";$B$2:$B$11;"<>122";$B$2:$B$11;"<>128")+...
Макрос копирующий диапазон в новый лист с сохранением настроек
 
Код
Sub SozdatFajl2()
    ActiveSheet.Copy
    Range("S1:XFD1048576").Delete Shift:=xlToLeft
    Range("A1:I1048576").Delete Shift:=xlToLeft
    Rows("46:1048576").Delete Shift:=xlUp
    ActiveWorkbook.SaveAs Filename:="C:\Users\TsarakovRCh\Documents\Тестирование\Деффектная ведомость.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub
Подбор к комбинации из шести чисел неизвестных слагаеммых(от 1 до 49) к желаемой сумме слагаеммых
 
#7 без повторов.
Код
Sub Спортлото89()
    Dim arr As Variant
    arr = GetArr(Range("A1:G1"))
    Range("B2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function GetArr(r As Range) As Variant
    Dim s As Long
    s = r.Cells(1, 1).Value
    Dim arr As Variant
    arr = r.Range("B1:G1")
    Dim x As Long
    Dim y As Long
    y = 1
    For x = UBound(arr, 2) To 1 Step -1
        If arr(1, x) = "" Then
            y = y * 49
        End If
    Next
    Dim brr As Variant
    If y > Rows.Count - 2 Then y = Rows.Count - 2
    ReDim brr(1 To y, 1 To 6)
    If y > 1 Then
        Dim i1 As Byte
        Dim i2 As Byte
        Dim i3 As Byte
        Dim i4 As Byte
        Dim i5 As Byte
        Dim i6 As Byte
        y = 0
        
        For i1 = IIf(arr(1, 1) = "", 1, arr(1, 1)) To IIf(arr(1, 1) = "", 49, arr(1, 1))
        For i2 = IIf(arr(1, 2) = "", i1 + 1, arr(1, 2)) To IIf(arr(1, 2) = "", 49, arr(1, 2))
        For i3 = IIf(arr(1, 3) = "", i2 + 1, arr(1, 3)) To IIf(arr(1, 3) = "", 49, arr(1, 3))
        For i4 = IIf(arr(1, 4) = "", i3 + 1, arr(1, 4)) To IIf(arr(1, 4) = "", 49, arr(1, 4))
        For i5 = IIf(arr(1, 5) = "", i4 + 1, arr(1, 5)) To IIf(arr(1, 5) = "", 49, arr(1, 5))
        For i6 = IIf(arr(1, 6) = "", i5 + 1, arr(1, 6)) To IIf(arr(1, 6) = "", 49, arr(1, 6))
            If s = i1 + i2 + i3 + i4 + i5 + i6 Then
                y = y + 1
                brr(y, 1) = i1
                brr(y, 2) = i2
                brr(y, 3) = i3
                brr(y, 4) = i4
                brr(y, 5) = i5
                brr(y, 6) = i6
            End If
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
    End If
    GetArr = brr
End Function
Заполнить карточку при вводе номера карточки
 
Код
='Нормы СИЗ'!H2            =ЕСЛИ(A2="";H1;A2)

A24       =ЕСЛИ(СТРОКА(A1)-1<СЧЁТЕСЛИ('Нормы СИЗ'!$G:$G;$M$13);ИНДЕКС('Нормы СИЗ'!$C:$C;МАКС(($O$12='Нормы СИЗ'!$H$2:$H$18)*($M$13='Нормы СИЗ'!$G$2:$G$18)*СТРОКА('Нормы СИЗ'!$G$2:$G$18))+СТРОКА(A1)-1);"")
AD24      =ЕСЛИ(СТРОКА(A1)-1<СЧЁТЕСЛИ('Нормы СИЗ'!$G:$G;$M$13);ИНДЕКС('Нормы СИЗ'!D:D;МАКС(($O$12='Нормы СИЗ'!$H$2:$H$18)*($M$13='Нормы СИЗ'!$G$2:$G$18)*СТРОКА('Нормы СИЗ'!$G$2:$G$18))+СТРОКА(A1)-1);"")
AQ24      =ЕСЛИ(СТРОКА(A1)-1<СЧЁТЕСЛИ('Нормы СИЗ'!$G:$G;$M$13);ИНДЕКС('Нормы СИЗ'!E:E;МАКС(($O$12='Нормы СИЗ'!$H$2:$H$18)*($M$13='Нормы СИЗ'!$G$2:$G$18)*СТРОКА('Нормы СИЗ'!$G$2:$G$18))+СТРОКА(A1)-1);"")
Сравнить два списка по Ф.И.О и формирование таблицы с Ф.И.О. и телефонными номерами
 
Телефоны получателей
Код
=ВПР(F:F;C:D;2;0)
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 121 След.
Наверх