管理 intersect VBA 函数
Managing the intersect VBA function
我目前正在实施一些 VBA 代码，允许列表框在某些列上触发，然后一旦填充到单元格中，就会填充 selection。最初的解决方案改编自 Checkboxes for multiple values in a single cell in Excel 除了我希望它触发整个列中的特定单元格而不是在特定单元格上触发。我已经设法很好地调整此代码并填充框，但它们仅在下一个 selected 单元格位于整个列之外时更新（因为它们仍然落在相交范围内）。有没有办法允许相交来解释任何细胞 selection 的变化？我只想填写内容，而不管我 select 不同列（有效）或不同行（无效）上的单元格。我已将代码放在这里，但它是上面链接代码的广泛副本。
提前致谢！
Option Explicit
Dim fillRng As Range
Dim fillRngp As Range
Dim fillRngr As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBPers As MSForms.ListBox
Dim LBRec As MSForms.ListBox
Dim LBobj As OLEObject
Dim LBoba As OLEObject
Dim LBObr As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Process")
Set LBColors = LBobj.Object
Set LBoba = Me.OLEObjects("LB_Personal")
Set LBPers = LBoba.Object
Set LBObr = Me.OLEObjects("LB_Record")
Set LBRec = LBObr.Object
If Selection.Count > 1 Then
Else
If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
Set fillRng = Target
With LBColors
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRng.Value = "" Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("M5:M10000")) Is Nothing Then
Set fillRngp = Target
With LBPers
.Left = fillRngp.Offset(0, 1).Left
.Top = fillRngp.Offset(0, 1).Top
.Width = fillRngp.Offset(0, 1).Width
.Visible = True
End With
Else
LBoba.Visible = False
If Not fillRngp Is Nothing Then
fillRngp.ClearContents
With LBPers
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngp.Value = "" Then
If .Selected(i) Then fillRngp.Value = .List(i)
Else
If .Selected(i) Then fillRngp.Value = _
fillRngp.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRngp = Nothing
Set fillRng = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("O5:O10000")) Is Nothing Then
Set fillRngr = Target
With LBRec
.Left = fillRngr.Offset(0, 1).Left
.Top = fillRngr.Offset(0, 1).Top
.Width = fillRngr.Offset(0, 1).Width
.Visible = True
End With
Else
LBRec.Visible = False
If Not fillRngr Is Nothing Then
fillRngr.ClearContents
With LBRec
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngr.Value = "" Then
If .Selected(i) Then fillRngr.Value = .List(i)
Else
If .Selected(i) Then fillRngr.Value = _
fillRngr.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
End If
End Sub
试试这个 - 在您发布的版本中有很多重复，可以排除，因为所有三个列表框都以相同的方式使用。
我还添加了一个方法来将列表框与单元格中已有的任何现有数据同步。
Option Explicit
Dim fillRng As Range 'any previously-selected cell
Dim theOLE As OLEObject 'any visible listbox container
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim theLB As MSForms.ListBox
'any list visible ?
If Not theOLE Is Nothing Then
'clean up after previous list editing
Set theLB = theOLE.Object 'from the global
fillRng.Value = LBSelectedItems(theLB) 'comma-separated list of selections
theOLE.Visible = False
Set theOLE = Nothing 'clear globals
Set fillRng = Nothing
End If
'need to exit now?
If Target.Count <> 1 Then Exit Sub
If Target.Row < 5 Or Target.Row > 10000 Then Exit Sub
'which column are we dealing with
Select Case Target.Column
Case 7: Set theOLE = Me.OLEObjects("LB_Process")
Case 13: Set theOLE = Me.OLEObjects("LB_Personal")
Case 15: Set theOLE = Me.OLEObjects("LB_Record")
Case Else: Exit Sub '<< nothing else to do here
End Select
Set fillRng = Target ' populate globals
Set theLB = theOLE.Object
SetList fillRng, theLB ' any cell value to sync with the list?
With theLB
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
End Sub
'select list items, based on any existing value in the cell
Sub SetList(rng As Range, LB As MSForms.ListBox)
Dim arr, i As Long
If Len(rng.Value) = 0 Then Exit Sub 'nothing to do...
arr = Split(rng.Value, ",") 'existing choices are comma-delimited
For i = 0 To LB.ListCount - 1
'?list item matches value from cell?
If Not IsError(Application.Match(LB.List(i), arr, 0)) Then
LB.Selected(i) = True
End If
Next i
End Sub
'return a comma-delimted list of selected items from a listbox
Function LBSelectedItems(LB As MSForms.ListBox)
Dim i As Long, lst, sep
For i = 0 To LB.ListCount - 1
If LB.Selected(i) Then
lst = lst & sep & LB.List(i)
sep = "," 'at least one selection, so need a separator
LB.Selected(i) = False 'deselect after checking
End If
Next i
LBSelectedItems = lst
End Function
我目前正在实施一些 VBA 代码，允许列表框在某些列上触发，然后一旦填充到单元格中，就会填充 selection。最初的解决方案改编自 Checkboxes for multiple values in a single cell in Excel 除了我希望它触发整个列中的特定单元格而不是在特定单元格上触发。我已经设法很好地调整此代码并填充框，但它们仅在下一个 selected 单元格位于整个列之外时更新（因为它们仍然落在相交范围内）。有没有办法允许相交来解释任何细胞 selection 的变化？我只想填写内容，而不管我 select 不同列（有效）或不同行（无效）上的单元格。我已将代码放在这里，但它是上面链接代码的广泛副本。
提前致谢！
Option Explicit
Dim fillRng As Range
Dim fillRngp As Range
Dim fillRngr As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBPers As MSForms.ListBox
Dim LBRec As MSForms.ListBox
Dim LBobj As OLEObject
Dim LBoba As OLEObject
Dim LBObr As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Process")
Set LBColors = LBobj.Object
Set LBoba = Me.OLEObjects("LB_Personal")
Set LBPers = LBoba.Object
Set LBObr = Me.OLEObjects("LB_Record")
Set LBRec = LBObr.Object
If Selection.Count > 1 Then
Else
If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
Set fillRng = Target
With LBColors
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRng.Value = "" Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("M5:M10000")) Is Nothing Then
Set fillRngp = Target
With LBPers
.Left = fillRngp.Offset(0, 1).Left
.Top = fillRngp.Offset(0, 1).Top
.Width = fillRngp.Offset(0, 1).Width
.Visible = True
End With
Else
LBoba.Visible = False
If Not fillRngp Is Nothing Then
fillRngp.ClearContents
With LBPers
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngp.Value = "" Then
If .Selected(i) Then fillRngp.Value = .List(i)
Else
If .Selected(i) Then fillRngp.Value = _
fillRngp.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRngp = Nothing
Set fillRng = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("O5:O10000")) Is Nothing Then
Set fillRngr = Target
With LBRec
.Left = fillRngr.Offset(0, 1).Left
.Top = fillRngr.Offset(0, 1).Top
.Width = fillRngr.Offset(0, 1).Width
.Visible = True
End With
Else
LBRec.Visible = False
If Not fillRngr Is Nothing Then
fillRngr.ClearContents
With LBRec
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngr.Value = "" Then
If .Selected(i) Then fillRngr.Value = .List(i)
Else
If .Selected(i) Then fillRngr.Value = _
fillRngr.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
End If
End Sub
试试这个 - 在您发布的版本中有很多重复，可以排除，因为所有三个列表框都以相同的方式使用。 我还添加了一个方法来将列表框与单元格中已有的任何现有数据同步。
Option Explicit
Dim fillRng As Range 'any previously-selected cell
Dim theOLE As OLEObject 'any visible listbox container
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim theLB As MSForms.ListBox
'any list visible ?
If Not theOLE Is Nothing Then
'clean up after previous list editing
Set theLB = theOLE.Object 'from the global
fillRng.Value = LBSelectedItems(theLB) 'comma-separated list of selections
theOLE.Visible = False
Set theOLE = Nothing 'clear globals
Set fillRng = Nothing
End If
'need to exit now?
If Target.Count <> 1 Then Exit Sub
If Target.Row < 5 Or Target.Row > 10000 Then Exit Sub
'which column are we dealing with
Select Case Target.Column
Case 7: Set theOLE = Me.OLEObjects("LB_Process")
Case 13: Set theOLE = Me.OLEObjects("LB_Personal")
Case 15: Set theOLE = Me.OLEObjects("LB_Record")
Case Else: Exit Sub '<< nothing else to do here
End Select
Set fillRng = Target ' populate globals
Set theLB = theOLE.Object
SetList fillRng, theLB ' any cell value to sync with the list?
With theLB
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
End Sub
'select list items, based on any existing value in the cell
Sub SetList(rng As Range, LB As MSForms.ListBox)
Dim arr, i As Long
If Len(rng.Value) = 0 Then Exit Sub 'nothing to do...
arr = Split(rng.Value, ",") 'existing choices are comma-delimited
For i = 0 To LB.ListCount - 1
'?list item matches value from cell?
If Not IsError(Application.Match(LB.List(i), arr, 0)) Then
LB.Selected(i) = True
End If
Next i
End Sub
'return a comma-delimted list of selected items from a listbox
Function LBSelectedItems(LB As MSForms.ListBox)
Dim i As Long, lst, sep
For i = 0 To LB.ListCount - 1
If LB.Selected(i) Then
lst = lst & sep & LB.List(i)
sep = "," 'at least one selection, so need a separator
LB.Selected(i) = False 'deselect after checking
End If
Next i
LBSelectedItems = lst
End Function