皆様、アドバイスありがとうございました。
無事にやりたかったことが解決できました。
文章だけですとなかなか伝えきれなくて申し訳ありませんでした。
繰り返しになってしまいますが、例えば、
TextBoxに1,2,3と手入力すると、
Listboxの1番目、2番目、3番目が選択される、
Listboxの1番目、2番目、3番目を選択すると、
TextBoxに1,2,3と入力される
イメージです。
実は、Excelのトピックに上げていますが、
実際はWordのVBAで図の相互参照を簡略化するマクロを組んでいました。
不要かと思いますが完成後のコードを転記します。
洗練されていない箇所も多々あると思いますがお許しください。
(すみません、フラグの所、頂いたものに直してないです。。。)
★------------------モジュール側------------------
Public modeF As Boolean
Public figlevl(999) As Variant
Public Fn As Variant
Public tempnumF As Variant
Public figurenum As String '図番号
Sub 図番の相互参照()
Dim Arrfigurenum As Variant
On Error GoTo 図番の相互参照_Error
Application.ScreenUpdating = False
ActiveDocument.Fields.Update
St = Selection.Start
Ed = Selection.End
ActiveWindow.View.ShowFieldCodes = True
Dim myRange As Range
Set myRange = Selection.Range
With myRange.Find
.Text = "SEQ 図"
.Forward = False
.Wrap = wdFindStop
' .Format = False
' .MatchCase = False '大文字と小文字の区別する
' .MatchWholeWord = False '完全に一致する単語だけを検索する
' .MatchAllWordForms = False '英単語の異なる活用形を検索する
' .MatchSoundsLike = False 'あいまい検索（英）
' .MatchFuzzy = False 'あいまい検索（日）
' .MatchByte = False '半角と全角を区別する
' .MatchWildcards = True 'ワイルドカードを使用する
c = 0
Do While .Execute
c = c + 1
Loop
tempnumF = c + 1
End With
ActiveDocument.Range(St, Ed).Select
Set myRange = Selection.Range
With myRange.Find
.Text = "SEQ 図"
.Forward = True
.Wrap = wdFindStop
' .Format = False
' .MatchCase = False '大文字と小文字の区別する
' .MatchWholeWord = False '完全に一致する単語だけを検索する
' .MatchAllWordForms = False '英単語の異なる活用形を検索する
' .MatchSoundsLike = False 'あいまい検索（英）
' .MatchFuzzy = False 'あいまい検索（日）
' .MatchByte = False '半角と全角を区別する
' .MatchWildcards = True 'ワイルドカードを使用する
cc = 0
Do While .Execute
cc = cc + 1
Exit Do
Loop
End With
If cc = 0 Then tempnumF = c
If c = 0 And cc = 0 Then tempnumF = ""
ActiveWindow.View.ShowFieldCodes = False
Set myRange = Nothing
'----図目次を挿入しリストを作成-----
ActiveDocument.Range(0, 0).Select
Selection.TypeParagraph
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With ActiveDocument
.TablesOfFigures.Add Range:=Selection.Range, Caption:="図", _
IncludeLabel:=True, RightAlignPageNumbers:=True, UseHeadingStyles:=False, _
UpperHeadingLevel:=1, LowerHeadingLevel:=3, IncludePageNumbers:=False, _
AddedStyles:="", UseHyperlinks:=True, HidePageNumbersInWeb:=True
ActiveDocument.Range(0, 0).Select
Fn = 0
For Each par In ActiveDocument.Paragraphs
With par
If .Range.Text = vbCr Then
GoTo line9
ElseIf .Range.Text <> "" Then
Fn = Fn + 1
figlevl(Fn) = Replace(.Range.Text, vbCr, "")
End If
End With
Next par
line9:
.TablesOfFigures(1).Delete
End With
Selection.Delete Unit:=wdCharacter, Count:=1
'-----------------------------------
ActiveDocument.Range(St, Ed).Select
'以下が無いと表示がなぜかずれる
Selection.TypeText "0"
Selection.TypeBackspace
Application.ScreenUpdating = True
'----------------------------------------
'●フォームshowとモードレスの一時停止処理
modeF = False
相互参照_図フォーム.Show vbModeless
'----------------------------------------
Do
DoEvents 'フォーム側にtrueのスイッチ
Loop Until modeF
'----------------------------------------
'数字のみに分解
Dim buf As String, RE, reMatch, reValue
Set RE = CreateObject("VBScript.RegExp")
Dim Num(999) As Integer
buf = figurenum
With RE
.Pattern = "\d+"
.Global = True
Set reMatch = .Execute(buf)
If reMatch.Count > 0 Then
T = 0
For Each reValue In reMatch
T = T + 1
Num(T) = reValue
Next reValue
End If
End With
Set RE = Nothing
For i = 1 To T
Selection.InsertCrossReference ReferenceType:="図", _
ReferenceKind:=wdOnlyLabelAndNumber, _
ReferenceItem:=CInt(Num(i))
If i <> T Then Selection.TypeText "、"
図番の相互参照_Error:
Next
Unload 相互参照_図フォーム
End Sub
★------------------フォーム側------------------
Option Base 1
Dim Textchange As Variant
Dim Listchange As Variant
Dim T As Variant
Private Sub ListBox1_Change()
If T = 1 Then
Textchange = False
If Listchange = True Then
s = ""
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
If s = "" Then
s = ListBox1.List(i)
Else
s = s & "," & ListBox1.List(i)
End If
TextBox1.Text = s
End If
Next i
End If
End If
Textchange = True
T = 1
End Sub
Private Sub TextBox1_Change()
If T = 1 Then
Listchange = False
If Textchange = True Then
For i = 0 To ListBox1.ListCount - 1 '選択状態を初期化
ListBox1.Selected(i) = False
Next i
'--数字のみに分解--
Dim buf As String, RE, reMatch, reValue
Set RE = CreateObject("VBScript.RegExp")
Dim Num(999) As Integer
buf = TextBox1.Value
With RE
.Pattern = "\d+"
.Global = True
Set reMatch = .Execute(buf)
If reMatch.Count > 0 Then
T = 0
For Each reValue In reMatch
T = T + 1
Num(T) = reValue
Next reValue
End If
End With
Set RE = Nothing
'------------------
On Error Resume Next '数字以外となった場合
For i = 1 To T
ListBox1.Selected(CLng(Num(i)) - 1) = True
Next i
End If
End If
Listchange = True
T = 1
End Sub
Private Sub UserForm_Activate()
T = 0
Textchange = True
Listchange = True
TextBox1.Value = tempnumF
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "20;120"
With ListBox1
For k = 1 To Fn
ListBox1.AddItem ""
.List(.ListCount - 1, 0) = k
.List(.ListCount - 1, 1) = figlevl(k)
Next k
End With
ListBox1.ListIndex = tempnumF - 1
End Sub
Private Sub CommandButton1_Click()
figurenum = TextBox1.Value
相互参照_図フォーム.hide
modeF = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Unload Me
figurenum = ""
modeF = True
End Sub
Private Sub CommandButton2_Click()
Unload Me
figurenum = ""
modeF = True
End Sub
