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

Страницы: 1 2 3 След.
Проверка значения ячеек и заполнение соседней
 
New, Благодарю, учту
Проверка значения ячеек и заполнение соседней
 
Ігор Гончаренко, Спасибо
Проверка значения ячеек и заполнение соседней
 
Msi2102, Ваш код на много лучше. У меня пока получается примитивными командами. Подскажите, почему при запуске вашего кода у меня потребовало обозначить переменные arr1 и arr2?
Проверка значения ячеек и заполнение соседней
 
Получилось решить задачу таким способом:
Код
Sub Name()
Dim a As Variant

For a = 2 To 30
          
            If Cells(a, "A") = "ОТИ-4" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда контролёров БТК"
               
            ElseIf Cells(a, "A") = "ОТИ-18" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда сверловщика"
  
            ElseIf Cells(a, "A") = "ОТИ-19" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда зубошлифовщика"
               
            ElseIf Cells(a, "A") = "ОТИ-22" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда протяжчика"
               
            ElseIf Cells(a, "A") = "ОТИ-52" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда шлифовщиков"
               
            ElseIf Cells(a, "A") = "ОТИ-53" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда при эскплуатации абразивного инструмента"
               
            ElseIf Cells(a, "A") = "ОТИ-57" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для фрезеровщика"
               
            ElseIf Cells(a, "A") = "ОТИ-60" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для грузчиков, и лиц, выполняющих погрузочно-разгрузочные и складские работы"
               
            ElseIf Cells(a, "A") = "ОТИ-65" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для стропальщиков"
               
            ElseIf Cells(a, "A") = "ОТИ-80" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для лиц, занятых управлением грузоподъёмными кранами с пола или стационарного пульта"
               
            ElseIf Cells(a, "A") = "ОТИ-118" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда при работе на координатно-измерительных машинах (КИМ)"
               
            ElseIf Cells(a, "A") = "ОТИ-144" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда при работе на долбёжных станках"
               
            ElseIf Cells(a, "A") = "ОТИ-192" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда зуборезчика"
               
            ElseIf Cells(a, "A") = "ОТИ-451" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда станочников"
               
            ElseIf Cells(a, "A") = "ОТИ-491" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для машинистов моечных машин"
               
            ElseIf Cells(a, "A") = "ОТИ-510" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для лиц, занятых обработкой металла с использованием смазочно-охлаждающих жидкостей"
               
            ElseIf Cells(a, "A") = "ОТИ-810" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда при работе с ручным слесарным инструментом"
               
            ElseIf Cells(a, "A") = "ОТИ-1012" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для дефектоскопистов по магнитному и ультразвуковому контролю"
               
            ElseIf Cells(a, "A") = "ОТИ-1244" Then
               Worksheets("Список инструкций").Cells(a, "D") = "По охране труда для операторов станков с программным управлением"
                
            End If
Next
    
End Sub
Проверка значения ячеек и заполнение соседней
 
Ігор Гончаренко, Спасибо. С ВПР да, получается реализовать. Хочу именно в vba, чтобы не добавлять лист в документ и названия тянулись из кода. Понимаю что нужно будет все условия прописать. Я не селен в vba похожего примера на форумах не нашел
Проверка значения ячеек и заполнение соседней
 
Добрый день!
Подскажите как сделать макросом, проверку значения в колонке А и согласно найденному значению заполнять соответствующую ячейку в колонке С.
Например: проверяем А2 если там ОТИ-4 тогда заполняем в С2 "По охране труда контролёров БТК". Вариантов значений будет порядка 20. То есть  если в А2 другое значение то в С2 тоже другие данные. Ниже привел соответствие ОТИ и данным в колонке С
ОТИ-4По   охране труда контролёров БТК
ОТИ-18По охране труда сверловщика
ОТИ-19По охране труда   зубошлифовщика
ОТИ-22По охране труда протяжчика
ОТИ-52По охране труда шлифовщиков
ОТИ-53По охране труда при   эскплуатации абразивного инструмента
ОТИ-57По охране труда для   фрезеровщика
ОТИ-60По охране труда для   грузчиков, и лиц, выполняющих погрузочно-разгрузочные и складские работы
ОТИ-65По охране труда для   стропальщиков
ОТИ-80По охране труда для лиц,   занятых управлением грузоподъёмными кранами с пола или стационарного пульта
ОТИ-118По охране труда при работе   на координатно-измерительных машинах (КИМ)
ОТИ-144По охране труда при работе   на долбёжных станках
ОТИ-192По охране труда зуборезчика
ОТИ-451По охране труда станочников
ОТИ-491По охране труда для   машинистов моечных машин
ОТИ-510По охране труда для лиц,   занятых обработкой металла с использованием смазочно-охлаждающих жидкостей
ОТИ-810По охране труда при работе   с ручным слесарным инструментом
ОТИ-1012По охране труда для   дефектоскопистов по магнитному и ультразвуковому контролю
ОТИ-1244По охране труда для   операторов станков с программным управлением
Формирование списка разделяя текст в ячейке по строкам
 
Вроде бы получилось. Я указал на каком листе искать последнюю заполненную строчку:
Код
Sub aaaaaaaaaaaaaaa()
Dim arr As Variant, arr1 As Variant, arr2 As Variant, dic As Variant, i As Variant, n As Variant, y As Variant

Set dic = CreateObject("Scripting.Dictionary")
arr1 = Sheets("Рабочая база деталей").Range("A9:H" & Sheets("Рабочая база деталей").Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(arr1)
    arr = Split(arr1(i, 8), "; ")
    For n = LBound(arr) To UBound(arr)
        If Not dic.exists(arr(n)) Then Set dic(arr(n)) = CreateObject("Scripting.Dictionary")
        If Not dic(arr(n)).exists(CStr(arr1(i, 5))) Then dic(arr(n)).Add CStr(arr1(i, 5)), CStr(arr1(i, 5))
    Next
Next
ReDim arr2(1 To dic.Count, 1 To 2)
n = 0
For Each y In dic
    n = n + 1
    arr2(n, 1) = y
    arr2(n, 2) = Join(dic(y).keys, "; ")
Next
Worksheets("Список инструкций").Cells(2, 1).Resize(UBound(arr2), 2) = arr2
End Sub
Формирование списка разделяя текст в ячейке по строкам
 
Msi2102, Поменялась немного структура документа. С листа "Список инструкций"? Чтобы кнопка была не на листе Данные... Пытался сделать, но почему-то если запустить с другого листа данные выдает совершено другие
Изменено: Денис Ш. - 29.07.2022 16:34:46
Ошибка "Method range of object _worksheet failed"
 
Здравствуйте! При отработке макроса возникает ошибка "Method range of object _worksheet failed". Макрос ставит номера страниц на листах в книге.
Проблема начала возникать когда увеличилось число листов.
Подозреваю, что дело в количестве листов ОК, т.е. ОК1, ОК2, ОК3, ОК4, ОК5, .... ОК9 на них все отлично работает, а вот на ОК10 уже выдает ошибку

Ругается конкретно на строку:
Код
xSheet_xSheet_xSheet.Range("OK_SkvNum1").Value = List_List_List(2) 

В условии:

Код
If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "OК" & "*" Then
        If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "OК1" & "*" Then
        xSheet_xSheet_xSheet.Range("OK_SkvNum1").Value = List_List_List(2)
        Else
        xSheet_xSheet_xSheet.Range("CZ47").Value = List_List_List(2)
        End If
    End If

Код
List_List_List(1) = 0
List_List_List(2) = 1
For Each xSheet_xSheet_xSheet In ActiveWorkbook.Sheets
If xSheet_xSheet_xSheet.Visible = True Then List_List_List(1) = List_List_List(1) + 1
Next

For Each xSheet_xSheet_xSheet In ActiveWorkbook.Sheets
If xSheet_xSheet_xSheet.Visible = True Then
    
    If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "ТИТУЛ" & "*" Then
    xSheet_xSheet_xSheet.Range("SkvNumTotal").Value = List_List_List(1)
    xSheet_xSheet_xSheet.Range("SkvNum1").Value = List_List_List(2)
    xSheet_xSheet_xSheet.Range("DA31").Value = List_List_List(2)
    End If

    If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "МК" & "*" Then
        If StrConv(xSheet_xSheet_xSheet.Name, 1) = "МК1" Then
        xSheet_xSheet_xSheet.Range("SkvNum1").Value = List_List_List(2)
        Else
        xSheet_xSheet_xSheet.Range("da47").Value = List_List_List(2)
        End If
    End If

    If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "OК" & "*" Then
        If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "OК1" & "*" Then
        xSheet_xSheet_xSheet.Range("OK_SkvNum1").Value = List_List_List(2)
        Else
        xSheet_xSheet_xSheet.Range("CZ47").Value = List_List_List(2)
        End If
    End If
    
    If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "ВО" & "*" Then
        If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "ВО1" & "*" Then
        xSheet_xSheet_xSheet.Range("AY243").Value = List_List_List(2)
        Else
        xSheet_xSheet_xSheet.Range("AZ254").Value = List_List_List(2)
        End If
    End If
        
    If StrConv(xSheet_xSheet_xSheet.Name, 1) Like "*" & "КН" & "*" Then
    xSheet_xSheet_xSheet.Range("DA52").Value = List_List_List(2)
    End If
List_List_List(2) = List_List_List(2) + 1
End If
Next

Set xSheet_xSheet_xSheet = Nothing
Erase List_List_List
Изменено: Денис Ш. - 22.06.2022 23:41:08
Формирование списка разделяя текст в ячейке по строкам
 
artemkau88, Все круто, спасибо большое!
Формирование списка разделяя текст в ячейке по строкам
 
artemkau88, Добрый день. Немного не то. Листы ПИ1 и ПИ2 немного отличаются форматом, т.е. ПИ1 всегда должен быть первым, а вот ПИ2 уже множить по содержимому., вот как файл
Цитата
artemkau88, как говорят "аппетит приходит во время еды"
Можно тоже самое реализовать но заполнять таблицу на листе ПИ1:
Обозначение - список ОТИ
Номера операций - номера операций
Если строк не хватает, то перейти на лист ПИ2, если и с ним не хватает то добавить копию листа ПИ2
Прикрепленные файлы
И еще можно перенести номера операций в колонку крайнюю правую, сейчас вносятся в колонку с наименованием
Формирование списка разделяя текст в ячейке по строкам
 
artemkau88, Например, если не хватает двух листов для заполнения, то скопировать ПИ2 но под именем ПИ3 и заполнять оставшиеся в него
Формирование списка разделяя текст в ячейке по строкам
 
artemkau88, Спасибо, все круто, но когда избыток инструкций он перезаписывает их на листе ПИ2
Формирование списка разделяя текст в ячейке по строкам
 
artemkau88, как говорят "аппетит приходит во время еды"
Можно тоже самое реализовать но заполнять таблицу на листе ПИ1:
Обозначение - список ОТИ
Номера операций - номера операций
Если строк не хватает, то перейти на лист ПИ2, если и с ним не хватает то добавить копию листа ПИ2
Формирование списка разделяя текст в ячейке по строкам
 
artemkau88, Прошу простить меня, я последний что увидел попробовал и удалился от компа.
Ваш тоже делает то что надо, только поправил чуть-чуть, выводил не номер операции а номер цеха
Код
Sub Интрукция_Операция()
Dim arr, Dict As Object
Dim i, j, t, tmp, temp, lr As Long

arr = Worksheets("Данные").Cells(1, 1).CurrentRegion
Set Dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 7), ";") Then
        tmp = Split(arr(i, 7), ";")
        For Each j In tmp
            j = Trim(j)
            If InStr(j, ",") Then
                temp = Split(j, ",")
                For Each t In temp
                    t = Trim(t)
                    If Not Dict.exists(t) Then
                        Dict.Add t, arr(i, 5)
                    Else
                        If InStr(Dict(t), arr(i, 5)) = 0 Then
                            Dict(t) = Dict(t) & ";" & arr(i, 5)
                        End If
                    End If
                Next t
            
            Else
                If Not Dict.exists(j) Then
                    Dict.Add j, arr(i, 5)
                Else
                    If InStr(Dict(j), arr(i, 5)) = 0 Then
                        Dict(j) = Dict(j) & ";" & arr(i, 5)
                    End If
                End If
            End If
        Next j
    Else
        If Not Dict.exists(arr(i, 7)) Then
            Dict.Add arr(i, 7), arr(i, 5)
        Else
            If InStr(Dict(arr(i, 7)), arr(i, 5)) = 0 Then
                Dict(arr(i, 7)) = Dict(arr(i, 7)) & ";" & arr(i, 5)
            End If
        End If
    End If
Next i
With Worksheets("Список инструкций")
    .Range(.Cells(2, 1).End(xlDown), .Cells(2, 1).End(xlToRight)).ClearContents
For Each j In Dict.keys
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(lr + 1, 1) = j
    .Cells(lr + 1, 2) = Dict(j)
Next j
End With
End Sub
Формирование списка разделяя текст в ячейке по строкам
 
Msi2102, Спасибо, то что нужно, разобраться бы в этом теперь. Я пытался пойти в этом направлении
Код
Sub Список_инструкций()

Dim i&, x
Dim aaa As Variant
Dim zzz As Variant
Dim diapazon As Variant

diapazon = Range("G2:G5")

For Each zzz In diapazon
    For Each x In Split(zzz, "; ")
        If x <> "" Then i = i + 1: Cells(i, 12) = x
    Next x
Next zzz

Columns(12).RemoveDuplicates 1

End Sub
Формирование списка разделяя текст в ячейке по строкам
 
Msi2102, Запятая это ошибка в заполнении. ОТИ-80 и ОТИ-080 это разное
Формирование списка разделяя текст в ячейке по строкам
 
Добрый день!
Подскажите как можно реализовать на языке VBA, формирование списка?
В столбце "инструкция", на листе "данные" имеем перечень инструкций, они разделены ; (точкой с запятой), нужно на лист "Список инструкций" в колонку инструкция внести все инструкции без дубликатов.

Пример:
если в ячейке: ОТИ-1244; ОТИ-451; ОТИ-510, ОТИ-80
то сделать как:
ОТИ-1244
ОТИ-451
ОТИ-510
ОТИ-80

После сформированного списка на листе "Список инструкций" в колонку "Операция" занести все операции через ; (точкой с запятой) в которых используется эта инструкция.

Пример:
Имеем инструкцию ОТИ-080 она используется в операциях 005; 010
Вставка строки с форматом как сверху или снизу
 
Здравствуйте!
Возникла проблема с добавлениями строк в таблицу. У таблицы определены границы, но когда добавляешь новую строку строка добавляется как будто с очищенным форматом, хотя в свойствах стоит "как сверху". Подскажите что может быть причиной данной проблемы.
К сожалению файл меньше чем 500 кб не получается сделать.
Выложил на яндекс: https://disk.yandex.ru/i/YlgntPaoKJEonw
Очистка ячейки если имя листа равно значению
 
Всем большое спасибо.
Собрав все советы и рекомендации смог получить то что надо.
Если использовать строчку кода без Worksheets(a), то чистит только на том листе который активен:
Код
ElseIf NameLista2 = "КН" Then
                 Worksheets(a).Range("DA53:DF53").ClearContents

Выложу весь код, может пригодится кому-то:

Код
Sub NumeraciyUdalit()

    Dim a As Integer
    Dim NameLista As Variant
    Dim NameLista2 As Variant
    Dim NameLista3 As Variant
    
        For a = 1 To Worksheets.Count
            With Worksheets(a)
            
                 NameLista = .Name
                 NameLista2 = Left(NameLista, 2)
                 NameLista3 = Left(NameLista, 3)
                 
              If NameLista = "Титул" Then
                 Worksheets(a).Range("DA31:DF31").ClearContents         'Удалить нумерацию на титуле
                 
              ElseIf NameLista3 = "ВО1" Then
                 Worksheets(a).Range("AY243:BA243").ClearContents       'Удалить нумерацию на ВО
                 
              ElseIf NameLista2 = "ВО" Then
                 Worksheets(a).Range("AZ254:BA254").ClearContents       'Удалить нумерацию на ВО
                    
              ElseIf NameLista3 = "МК1" Then
                 Worksheets(a).Range("DA46:DF46").ClearContents         'Удалить нумерацию МК1

              ElseIf NameLista2 = "МК" Then
                 Worksheets(a).Range("DA47:DF47").ClearContents         'Удалить нумерацию МК1
                             
              ElseIf NameLista3 = "КН1" Then
                 Worksheets(a).Range("DA52:DF52").ClearContents         'Удалить нумерацию КН1
                                
              ElseIf NameLista2 = "КН" Then
                 Worksheets(a).Range("DA53:DF53").ClearContents         'Удалить нумерацию КН
                                   
              ElseIf NameLista3 = "ОК1" Then
                 Worksheets(a).Range("DA44:DF44").ClearContents         'Удалить нумерацию ОК1

              ElseIf NameLista2 = "ОК" Then
                 Worksheets(a).Range("CZ47:DF47").ClearContents         'Удалить нумерацию ОК
                 
              End If
        End With
    Next
End Sub
Очистка ячейки если имя листа равно значению
 
_Boroda_,
Так там так и написано
Очистка ячейки если имя листа равно значению
 
Msi2102,
Тоже не удаляет данные из ячейки. Я так понимаю мне проще сделать два условия, по одному чтобы проверял по двум символам по другому по трем
Очистка ячейки если имя листа равно значению
 
_Boroda_,
Такой вариант работает, но не совсем подходит под условие. Часть листов надо проверять по трем левым символам а часть по двум
Очистка ячейки если имя листа равно значению
 
Msi2102,
В данный момент очищает ячейку только на двух листах
Очистка ячейки если имя листа равно значению
 
Добрый день!
Я в vba не силен. Пытаюсь решить задачу очистки данных ячеек в книге если имя листа равно определенному значению. Написал код, но не на всех листах работает.
Предполагаю, что дело в этой строке: ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 3) = "ВО1" Then
Можно данную процедуру написать иначе?
Код
Sub NumeraciyDelet()

    Dim ListiVse As Long
    Dim Name As Variant
    Dim a As Integer                               'Счетчик
    Dim StartList As Long
    
    Dim Sheet As Variant
    
    ListiVse = Worksheets.Count
    StartList = 1
    
        For a = 1 To ListiVse
        
            Sheet = Left(Sheets(StartList).Name, 3)
        
              If Sheets(StartList).Name = "Титул" Then
                 Worksheets(StartList).Range("DA31:DF31").ClearContents                                     'Удалить нумерацию на титуле
                 
                 ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 3) = "ВО1" Then
                    Worksheets(StartList).Range("AY243:BA243").ClearContents                                'Удалить нумерацию на ВО1
                    
                    ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 2) = "ВО" Then
                       Worksheets(StartList).Range("AZ254:BA254").ClearContents                             'Удалить нумерацию на ВО
                    
                       'ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 3) = "МК1" Then
                          ElseIf Sheet = "МК1" Then
                          Worksheets(StartList).Range("SkvNum1").ClearContents                              'Удалить нумерацию МК1
                          
                          ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 2) = "МК" Then
                             Worksheets(StartList).Range("SkvNum2").ClearContents                           'Удалить нумерацию МК
                             
                             ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 3) = "КН1" Then
                                Worksheets(StartList).Range("DA52:DF52").ClearContents                      'Удалить нумерацию КН1
                                
                                ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 2) = "КН" Then
                                   Worksheets(StartList).Range("DA53:DF53").ClearContents                   'Удалить нумерацию КН
                                   
                                   ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 3) = "ОК1" Then
                                      Worksheets(StartList).Range("OK_SkvNum1").ClearContents               'Удалить нумерацию ОК1

                                      ElseIf Sheets(StartList).Name = Left(Sheets(StartList).Name, 2) = "ОК" Then
                                         Worksheets(StartList).Range("OK_SkvNum2").ClearContents            'Удалить нумерацию ОК
                                      
'                                      End If
'                                   End If
'                                End If
'                             End If
'                          End If
'                       End If
'                    End If
'                 End If
              End If

        StartList = StartList + 1

        Next
  
End Sub
Перемещение листов в книге, Перемещение листов согласно их имени
 
Ігор Гончаренко, Попробовал запустить Ваш код, выдает ошибку, не могу понять почему
Перемещение листов в книге, Перемещение листов согласно их имени
 
Добрый день!
Подскажите, как можно реализовать в VBA анализ листов книги и отсортировать их исходя из имени листов?
А именно на примере файла во вложении: имеем книгу с листами ОП-010, ОП-015, ОП-030, КН-010, КН-015, КН-030, ВО-1, ВО-2
Нужно вызовом макроса расставить листы в таком порядке: ВО-1, ВО-2, КН-010, ОП-010, КН-015, ОП-015, КН-030, ОП-030
Т.е. листы КН должны быть перед листами ОП согласно их номеру 010 перед 010
"Пропадает иконка автозаполнения после выполнения макроса поиска
 
New, А если внести "Вспомогательный инструмент"?
Посоветуйте как тогда лучше сделать запуск макроса?
"Пропадает иконка автозаполнения после выполнения макроса поиска
 
Здравствуйте!
Подскажите в чем проблема. Добавил в книгу макрос, который ищет необходимое значение ячейки и заполняет относительно ее другие.
Но возникла проблема после выполнения макроса, а именно, до выполнения макроса при протягивании ячеек появляется иконка параметров автозаполнения, после выполнения макроса она не появляется, приходится удалять строки которые заполнил макрос.
Подсчет количества уникальных по условию
 
Mershik,спасибо большое за помощь, как раз то что надо!
Страницы: 1 2 3 След.
Наверх