Страницы: 1 2 След.
RSS
Изменяющийся выпадающий список, зависящий от значений в другом файле
 
Не стал грузить EXCEL но вопрос такой
Есть протокол с датой
Есть реестр регистрации названий по дате
Вот в протоколе надо по дате выдать выпадающий список с другого файла если даты равны: во как.
 
Цитата
ZhdanovYUYU написал:
Не стал грузить EXCEL
Если решение не нужно, то правильно сделали.
И по поводу названия темы: предложите новое, из которого будет понятна задача - модераторы поменяют.
 
Прошу прощения!
В файле пояснение!
Вообще такое возможно реализовать или с разных файлов не получится.
Проблема еще в том что я не имею доступ ко второму файлу, только для чтения откуда необходимо брать выпадающий список, так бы можно было присвоить имя диапазону, думаю тогда проще было бы.
Изменено: ZhdanovYUYU - 11.12.2019 13:52:02
 
Цитата
Юрий М написал:
по поводу названия темы: предложите новое, из которого будет понятна задача - модераторы поменяют
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "H2" Then
        SetS GetS(Target.Value)
    End If
End Sub

Sub SetS(s As String)
    With Range("A8").Validation
        .Delete
        If s <> "" Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub

Function GetS(ByVal TargetValue As String) As String
    Dim sh As Worksheet: Set sh = Workbooks("выподающий список.xlsx").Sheets("Лист1")
    Dim r1 As Range: Set r1 = sh.Columns("Q:Q")
    Dim r2 As Range: Set r2 = sh.Columns("U:U")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(a2(y, 1)) = 0
        End If
    Next
    If dic.Count > 0 Then
        GetS = Join(dic.Keys(), ", ")
    End If
    Application.StatusBar = TargetValue & " " & GetS
End Function
В модуль листа.

Вариант названия темы: Изменяющийся выпадающий список, зависящий от значений в другом файле.
Изменено: МатросНаЗебре - 11.12.2019 16:47:46
 
Помогите связать вот эти 2 файла, прописывал в коде столбцы название страниц и файла но не как.
И как потом изменить связь кода, что бы ни с образца брал а привязать к оригиналу.

Скрытый текст
Изменено: ZhdanovYUYU - 12.12.2019 03:24:54
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "I8" Then
        SetS GetS(Target.Value)
    End If
End Sub
 
Sub SetS(s As String)
    With Range("B28").Validation
        .Delete
        If s <> "" Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub
 
Function GetS(ByVal TargetValue As String) As String
    Dim sh As Worksheet: Set sh = Workbooks("Реестр Регистрации инициатив текущий.xlsx").Sheets("Карьер")
    Dim r1 As Range: Set r1 = sh.Columns("E:E")
    Dim r2 As Range: Set r2 = sh.Columns("J:J")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(a2(y, 1)) = 0
        End If
    Next
    If dic.Count > 0 Then
        GetS = Join(dic.Keys(), ", ")
    End If
    Application.StatusBar = TargetValue & " " & GetS
End Function
В модуль листа Лист1.
 
Макрос не прошел. Я пошёл другим путем, создал второй лист где прописал формулу:
Код
ЕСЛИОШИБКА(ИНДЕКС('\\mos\ver\ОБЩАЯ\ТОП\[
Реестр Регистрации инициатив текущий.xlsx]Карьер'!$J$2:$J$1900;АГРЕГАТ(15;6;
(СТРОКА('\\mos\ver\ОБЩАЯ\ТОП\[Реестр Регистрации инициатив текущий.xlsx]
Карьер'!$F$2:$F$1900)-1)/('\\mos\ver\ОБЩАЯ\ТОП\[Реестр Регистрации инициатив текущий.xlsx]Карьер'!$F$2:$F$1900=$C$3);
СТРОКА('\\mos\ver\ОБЩАЯ\ТОП\[Реестр Регистрации инициатив текущий.xlsx]Карьер'!A1)));"")
, Потом протянул на необходимое количество строк, а на первом листе задал выпадающий список  с этого диапазона. Единственное что хочу еще сделать из полученного диапазона на втором листе которые выпадают на первый получить список только с уникальными значениями и переделать выпадающий список на них чтобы их было меньше и не повторялись.
 
Код
Sub SetS(s As String)
    With Range("B28").Validation
        .Delete
        If s <> "" Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub
 
Function GetS(ByVal TargetValue As String) As String
    Const wbName = "Реестр Регистрации инициатив текущий.xlsx"
    Const shName = "Карьер"
    
    Dim sh As Worksheet
    Dim wb As Workbook
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
        If Err <> 0 Then
            MsgBox "Не вижу файл " & wbName, vbInformation
            Exit Function
        End If
        
        Set sh = wb.Sheets(shName)
        If Err <> 0 Then
            MsgBox "Не вижу лист " & shName, vbInformation
            Exit Function
        End If
    On Error GoTo 0
    
    Dim r1 As Range: Set r1 = sh.Columns("E:E")
    Dim r2 As Range: Set r2 = sh.Columns("J:J")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(a2(y, 1)) = 0
        End If
    Next
    If dic.Count > 0 Then
        GetS = Join(dic.Keys(), ", ")
    End If
    Application.StatusBar = TargetValue & " " & GetS
End Function
 
В "не вижу файл и лист вставить название файла?
Если да то вставил.
Но в клетке В28 выпадающий список так и не появился, ошибку не выдал, сохранил открыл и снова  пусто
Там откуда берем данные Реестр регистрации несколько одинаковых дат может поэтому он не выдает список названия по этим датам.

Если есть возможность отправьте образец файла?
И в коде можно назначить несколько клеток куда будет выдаваться всплывающий список названий соответствующий дате рассотрения

P.S.
Файлы должны быть в одной папке, или можно обновить связь с файлом.
При обновлении связи код не перестраивается?
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "I8" Then
        Dim s As String
        s = GetS(Target.Value)
        Dim rangeName As Variant
        For Each rangeName In Array("B28", "B37")
            SetS s, rangeName
        Next
    End If
End Sub
 
Sub SetS(s As String, ByVal rangeName As String)
    With Range(rangeName).Validation
        .Delete
        If s <> "" Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub
 
Function GetS(ByVal TargetValue As String) As String
    Const wbName = "Реестр Регистрации инициатив текущий.xlsx"
    Const shName = "Карьер"
    
    Dim s As String
    Dim v As Variant
    
    Dim sh As Worksheet
    Dim wb As Workbook
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
        If Err <> 0 Then
            s = "Не вижу файл " & Chr(10) & wbName & Chr(10) & Chr(10) & "Вижу файлы:" & Chr(10)
            For Each v In Application.Workbooks
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            Exit Function
        End If
        
        Set sh = wb.Sheets(shName)
        If Err <> 0 Then
            s = "Не вижу лист " & Chr(10) & shName & Chr(10) & Chr(10) & "Вижу листы:" & Chr(10)
            For Each v In wb.Worksheets
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            
            
            Exit Function
        End If
    On Error GoTo 0
    
    Dim r1 As Range: Set r1 = sh.Columns("E:E")
    Dim r2 As Range: Set r2 = sh.Columns("J:J")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(a2(y, 1)) = 0
        End If
    Next
    If dic.Count > 0 Then
        GetS = Join(dic.Keys(), ", ")
    End If
    Application.StatusBar = TargetValue & " " & GetS
End Function
 
Цитата
ZhdanovYUYU написал: В "не вижу файл и лист вставить название файла?Если да то вставил.
Имя файла и листа нужно вставить сюда:
Код
    Const wbName = "Реестр Регистрации инициатив текущий.xlsx"
    Const shName = "Карьер"

Цитата
Если есть возможность отправьте образец файла?
Увы, не загружается.

Цитата
И в коде можно назначить несколько клеток
Можно задать в строке:
Код
For Each rangeName In Array("B28", "B37")

Цитата
[Файлы должны быть в одной папке,
Расположение файла значение не имеет. Файл должен быть открыт.
И если уж совсем точно, файл должен быть открыть в том же экземпляре приложения.
 
Повторно выдал!
 
Цитата
ZhdanovYUYU написал:
Но в клетке В28 выпадающий список так и не появился, ошибку не выдал, сохранил открыл и снова  пусто
О том, что макрос запускается по изменению значения в ячейке I8, видимо, Вы знаете.
Какое значение Вы вносите в эту ячейку?
 
Пишет не вижу файл Реестр Регистрации инициатив
Вижу файл Протокол Рабочих групп
 
В открытом файле Протокол... нажмите Ctrl+O.
Откройте файл Реестр...

В смысле надо открыть не из проводника, а в том же экземпляре приложения.
Можно сделать, чтоб макрос это делал.
 
Так заработал но только выдал последнюю запись соответствующей дате
А их 18 записей с одной датой
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "I8" Then
        Dim s As String
        s = GetS(Target.Value)
        Dim rangeName As Variant
        For Each rangeName In Array("B28", "B37")
            SetS s, rangeName
        Next
    End If
End Sub
 
Sub SetS(s As String, ByVal rangeName As String)
    With Range(rangeName).Validation
        .Delete
        If s <> "" Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub
 
Function GetS(ByVal TargetValue As String) As String
    Const fileFullName = "C:\tmp\Реестр Регистрации инициатив текущий.xlsx"
    Const wbName = "Реестр Регистрации инициатив текущий.xlsx"
    Const shName = "Карьер"
    
    Dim s As String
    Dim v As Variant
    
    Dim sh As Worksheet
    Dim wb As Workbook
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = Workbooks.Open(fileFullName, False, True)
    End If
    ThisWorkbook.Activate
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
        If Err <> 0 Then
            s = "Не вижу файл " & Chr(10) & wbName & Chr(10) & Chr(10) & "Вижу файлы:" & Chr(10)
            For Each v In Application.Workbooks
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            Exit Function
        End If
        
        Set sh = wb.Sheets(shName)
        If Err <> 0 Then
            s = "Не вижу лист " & Chr(10) & shName & Chr(10) & Chr(10) & "Вижу листы:" & Chr(10)
            For Each v In wb.Worksheets
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            
            
            Exit Function
        End If
    On Error GoTo 0
    
    Dim r1 As Range: Set r1 = sh.Columns("F:F")
    Dim r2 As Range: Set r2 = sh.Columns("J:J")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(a2(y, 1)) = 0
        End If
    Next
    If dic.Count > 0 Then
        GetS = Join(dic.Keys(), ", ")
    End If
    Application.StatusBar = Left(TargetValue & " " & GetS, 255)
End Function
Так макрос сам откроет файл.
Не забудьте указать полный путь файла, там же в константах.
Изменено: МатросНаЗебре - 12.12.2019 13:10:36
 
Цитата
ZhdanovYUYU написал:
Так заработал но только выдал последнюю запись соответствующей датеА их 18 записей с одной датой
В том файле, что Вы выложили, нет даты с 18-ю записями.
Вы какую дату вводите?
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "I8" Then
        Dim s As String
        s = GetS(Target.Value)
        Dim rangeName As Variant
        For Each rangeName In Array("B28", "B37")
            SetS s, rangeName
        Next
    End If
End Sub
 
Sub SetS(s As String, ByVal rangeName As String)
    With Range(rangeName).Validation
        .Delete
        If s <> "" Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub
 
Function GetS(ByVal TargetValue As String) As String
    Const fileFullName = "C:\tmp\Реестр Регистрации инициатив текущий.xlsx"
    Const wbName = "Реестр Регистрации инициатив текущий.xlsx"
    Const shName = "Карьер"
    
    Dim s As String
    Dim v As Variant
    
    Dim sh As Worksheet
    Dim wb As Workbook
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = Workbooks.Open(fileFullName, False, True)
    End If
    ThisWorkbook.Activate
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
        If Err <> 0 Then
            s = "Не вижу файл " & Chr(10) & wbName & Chr(10) & Chr(10) & "Вижу файлы:" & Chr(10)
            For Each v In Application.Workbooks
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            Exit Function
        End If
        
        Set sh = wb.Sheets(shName)
        If Err <> 0 Then
            s = "Не вижу лист " & Chr(10) & shName & Chr(10) & Chr(10) & "Вижу листы:" & Chr(10)
            For Each v In wb.Worksheets
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            
            
            Exit Function
        End If
    On Error GoTo 0
    
    Dim r1 As Range: Set r1 = sh.Columns("F:F")
    Dim r2 As Range: Set r2 = sh.Columns("J:J")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(Replace(a2(y, 1), ",", "_")) = 0
        End If
    Next
    If dic.Count > 0 Then
        GetS = Join(dic.Keys(), ", ")
    End If
    Application.StatusBar = Left(TargetValue & " " & GetS, 255)
End Function
Поправил баг с запятой.
 
АЖ подпрыгнул, напарника испугал )))))
Заработал !!!!!!!!!!!!  Спасибо!!!!!!
На сколько записей он рассчитан?
Как в при необходимости можно увеличить диапазон?
 
Вы имеете в виду, как добавить ячейки, в которых должен быть выпадающий список? Тогда допишите адреса сюда:
Код
Array("B28", "B37")
 
 Как вариант я бы сделал так:
1) написал бы макрос который вытягивает из закрытой книги с нужного листа нужный диапазон (тут только указать адрес к файлу)
2) после загрузки данных провел бы форматирование (если чтото не нужно) либо перед загрузкой данных поигрался бы в открывающимся файле с фильтрами
3) потом уже над правельными даными провел работу в текущем документе
 
Как добавить в какие клетки выпадать списку я нашол. Мне интересно в самом списке который будет выпадать есть ограничения. И в работе столкнулся с тем что если в наименовании (которое выпадает) стоит занятая то он делит на две записи и выпадают по половинке отдельно.
 
Цитата
ZhdanovYUYU написал:
если в наименовании (которое выпадает) стоит занятая то он делит на две записи
В сообщении #20 этот баг учтён.

Цитата
ZhdanovYUYU написал:
в самом списке который будет выпадать есть ограничения
Я тестировал на 1000 строк, ограничение не нашёл.
 
Огромное спасибо за помощь!!!! :)
С запятой я думаю договорюсь что при заполнении её не будут проставлять.
А так получился файл который облегчит работу на 3-4 часа в неделю в 6 подразделениях.
 
Способствуете сокращению штата? :)
 
В основе лежит повышение производительности, ввиду загруженности сотрудников рутинной работой на постоянной основе 1/7/365
 
Как можно убрать просмотр запятой или точки и оставить вывод всей клетки МатросНаЗебре,
 
GetS = Join(dic.Keys(), ", ")
Тут я пробовал и точку прописать, и пустым оставить но периодически работает не корректно.
Что прописать для определения конкретно клетки, чтобы не разделять текст в клетке на разный позиции в выпадающем списке.
 
Страницы: 1 2 След.
Наверх