| |
午前中にいちど投稿しましたが、
リストボックスrirekiの更新に不具合があったので、一度削除して
再掲します。
リストボックス rireki の項目数は リストボックスSBで新しい
アイテムが追加されるたびに、元データ範囲の行数は増えていく
ということですね
深く検証してませんが、こんなのでいちど試してみてください。
リスト(のRowSource)にあるか検索は WorksheetFunction.Matchを
Applicationオブジェクトのメソッドとして利用しています。
'----------------------- Sheet1 モジュールに記述
Private Sub Worksheet_BeforeDoubleClick( _
ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 10 Then Exit Sub
If Target.Row >= 5 Then
Cancel = True
行 = Target.Row
列 = Target.Column
UserForm1.Show '0
End If
End Sub
'------------------------ Useform1に記述
Option Explicit
Private WS2 As Worksheet
Private Sub UserForm_Initialize()
Dim r As Range
Set WS2 = Worksheets("Sheet2")
Set r = WS2.[J3]
Set r = WS2.Range(r, r.End(xlDown))
SB.RowSource = r.Address(External:=True)
SB.ColumnHeads = True
End Sub
Private Sub UserForm_Activate()
Dim r As Range
Set r = WS2.[L3]
Set r = WS2.Range(r, r.End(xlDown))
rireki.RowSource = ""
rireki.RowSource = r.Address(External:=True)
rireki.ColumnHeads = True
End Sub
Private Sub SB_Click()
'ダブルクリックされたセルに選択アイテムを代入する
ActiveCell.Value = SB.Value
Dim m As Variant
Dim r As Range
Set r = WS2.Range("L3")
Set r = Excel.Range(r, r.End(xlDown)) 'L列リストにあるか
m = Application.Match(SB.Value, r, 0)
If IsNumeric(m) Then
'すでにあれば、そのセルを一番上[L3] に移動
If m > 1 Then
r.Item(m).Cut
r.Item(1).Insert shift:=xlDown
End If
Else
'ないときは L列の一番上に挿入
Application.CutCopyMode = False
r.Item(1).Insert shift:=xlDown
r.Item(0).Value = SB.Value
'RowSourceを更新
rireki.RowSource = _
r.Item(0).Resize(r.Count + 1).Address(External:=True)
End If
Me.Hide
End Sub
Private Sub rireki_Click()
Dim m As Long
If rireki.ListIndex > -1 Then
'ダブルクリックされたセルに選択アイテムを代入する
ActiveCell.Value = rireki.Value
m = rireki.ListIndex + 1
If m > 1 Then
Dim r As Range
Set r = WS2.Range("L3")
Set r = Excel.Range(r, r.End(xlDown)) 'L列リスト
'そのセルを一番上[L3] に移動
r.Item(m).Cut
r.Item(1).Insert shift:=xlDown
End If
Me.Hide
End If
End Sub
|
|
kanabun
- 10/4/18(日) 15:03 -
