Страницы: 1
RSS
Удаление использованных данных из выпадающего списка и прописывание их в отдельную таблицу
 
У меня в файле есть макрос, который удаляет использованные значения выпадающего списка и прописывает в столбец C листа 2, но после выбора одного из значения выпадающего списка, выпадающий список пропадает, не знаете, как решить эту проблему? Также формула выпадающего списка в столбце B некорректно ссылается на значения умной таблицы листа 2.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                Dim ValidFormula As String
                ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                If sh.Cells(2, 3) = "" Then
                sh.Cells(2, 3) = Target
                Else
                lr = sh.Cells(Rows.Count, 3).End(xlUp).Row - 1
                sh.Cells(lr, 3).ListObject.ListRows.Add AlwaysInsert:=True
                sh.Cells(lr + 1, 3).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub
Изменено: Ибрагим Белхороев - 10.06.2022 08:01:09
 
Кто нибудь может помочь?
 
Можно заменить формулу "Номера" на
Код
=ДВССЫЛ("Таблица1["&Лист1!$A$1&"]")
 
Цитата
Ибрагим Белхороев написал:
У меня в файле есть макрос
Если что в xlsx макросы не живут.
 
МатросНаЗебре, а как в коде прописать, чтобы использованные номера прописывались именно в таблицу2, а не в столбец этой таблицы?
Изменено: Ибрагим Белхороев - 10.06.2022 10:40:16
 
Цитата
написал:
использованные номера прописывались именно в таблицу2, а не в столбец этой таблицы?
Не понял, нужен пример.
 
Для коллекции
Выпадающий список с удалением использованных элементов
 
МатросНаЗебре, Из этого кода нужно изменить
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                Dim ValidFormula As String
                ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                If sh.Cells(2, 3) = "" Then
                sh.Cells(2, 3) = Target
                Else
                lr = sh.Cells(Rows.Count, 3).End(xlUp).Row - 1 "
                sh.Cells(lr, 3).ListObject.ListRows.Add AlwaysInsert:=True
                sh.Cells(lr + 1, 3).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub

Вот эти строки

Код
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                Dim ValidFormula As String
                ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                If sh.Cells(2, 3) = "" Then
                sh.Cells(2, 3) = Target
                Else
                lr = sh.Cells(Rows.Count, 3).End(xlUp).Row - 1 "
                sh.Cells(lr, 3).ListObject.ListRows.Add AlwaysInsert:=True
                sh.Cells(lr + 1, 3).Value = Target
                End If

Так, чтобы значения из выпадающего прописывались не в третий столбец листа 2, а в таблицу2 в этом же листе. Это нужно для того, чтобы при расширении таблицы1, каждый раз не менять номер столбца в коде, куда должны прописываться выбранные значения из выпадающего списка.
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                Dim ValidFormula As String
                ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                Dim xtb2 As Long
                xtb2 = sh.ListObjects("Таблица2").Range.Column
                If sh.Cells(2, xtb2) = "" Then
                    sh.Cells(2, xtb2) = Target
                Else
                    lr = sh.Cells(Rows.Count, xtb2).End(xlUp).Row - 1
                    sh.Cells(lr, xtb2).ListObject.ListRows.Add AlwaysInsert:=True
                    sh.Cells(lr + 1, xtb2).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub
 
МатросНаЗебре,
Код
=ДВССЫЛ("Таблица1["&Лист1!$A$1&"]")
А как сделать, чтобы в выпадающем списке не выводились нули?
Изменено: Ибрагим Белхороев - 10.06.2022 13:52:56
 
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                
                Dim ValidFormula As String
                'ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                ValidFormula = GetValidFormula(sh, [A1].Value)
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                Dim xtb2 As Long
                xtb2 = sh.ListObjects("Таблица2").Range.Column
                If sh.Cells(2, xtb2) = "" Then
                    sh.Cells(2, xtb2) = Target
                Else
                    lr = sh.Cells(Rows.Count, xtb2).End(xlUp).Row - 1
                    sh.Cells(lr, xtb2).ListObject.ListRows.Add AlwaysInsert:=True
                    sh.Cells(lr + 1, xtb2).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub

Function GetValidFormula(sh As Worksheet, colName As String) As String
    Dim arr As Variant
    On Error Resume Next
    arr = sh.ListObjects("Таблица1").ListColumns(colName).DataBodyRange.Resize(, 2)
    On Error GoTo 0
    If Not IsEmpty(arr) Then
        Dim brr As Variant
        Dim yy As Long
        Dim uu As Long
        Dim ii As Long
        For ii = 0 To 1
            uu = 0
            For yy = 1 To UBound(arr, 1)
                If Not IsEmpty(arr(yy, 1)) Then
                    uu = uu + 1
                    If ii Then
                        brr(uu) = arr(yy, 1)
                    End If
                End If
            Next
            If uu Then
                If ii Then
                    GetValidFormula = Join(brr, ",")
                Else
                    ReDim brr(1 To uu)
                End If
            End If
        Next
    End If
End Function
 
МатросНаЗебре,  спасибо. А без макроса нельзя как то изменить формулу в сообщении #3, чтобы в выпадающем списке не показовались нули?
 
Создаём имя Номера2
Код
=СМЕЩ(Лист2!$J$1;1;0;Лист2!$J$1;1)
Это имя ставим в проверку данных.

На Лист2 создаём дополнительные столбцы
Код
H2        =H1+(Номера<>0)
I2        =Номера
J2        =ВПР(СТРОКА(J1);H:I;2;0)
Тянем вниз

В J1 вносим формулу
Код
=МАКС(H:H)




Цитата
написал:
А без макроса нельзя как то
Можно. Но выглядит как минимум необычно, использовать макрос и в середине "не использовать макрос".
 
МатросНаЗебре, макрос немного некорректно работает. Нужно сначала выбрать в выпадающем списке, чтобы потом пустые строки не отображались, а хотелось чтобы сразу пустые строки вообще не отображались в выпадающем списке.
Страницы: 1
Наверх