У меня в файле есть макрос, который удаляет использованные значения выпадающего списка и прописывает в столбец 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
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
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
МатросНаЗебре, макрос немного некорректно работает. Нужно сначала выбрать в выпадающем списке, чтобы потом пустые строки не отображались, а хотелось чтобы сразу пустые строки вообще не отображались в выпадающем списке.