Excel – 水色（仮）

Excel 2007

「データ > データの入力規則 > リスト」を使って VBA してみたけれど
なんともならんので、フォームを使って試したメモ
やはりどうも VBA は好きになれないでござる…

こんなのを作る、入力に使用するキー: TAB, UP, DOWN, ENTER…

Book: DropDownSuggest-05.xlsm

Form:

フォーム (FormDropDownList) の中にリストボックス (ListBox1) を1個配置する

FormDropDownList
+ ListBox1

Sheets:

Sheet1: 入力用
Sheet2: シート切り替え時のテスト用
DropDownDataList: ドロップダウンリストのデーター用

DropDownDataList (Sheet) :

セル A1〜An へ候補として表示したいデーターを入力しておく

Sheet1 (Sheet Module) :

'
' SheetModule
'

Option Explicit

Private ActiveDropDownList As Boolean

' ワークシートがアクティブになると実行される
Private Sub Worksheet_Activate()
    GuessStatus ActiveCell
End Sub

' ワークシートが非アクティブになると実行される
Private Sub Worksheet_Deactivate()
    ActiveDropDownList = False
    Deactive
End Sub

' 選択されたセル範囲が変更されると実行される
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    GuessStatus Target
End Sub

' ワークシートの値が変更されると実行される
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If KeyEventCallbackRunning Then Exit Sub
    If ActiveDropDownList Then WorksheetOnChange Target
End Sub

Private Sub GuessStatus(Target As Object)
    If Application.Intersect(Target, Range("Sheet1!B:B")) Is Nothing Then
        ActiveDropDownList = False
        Deactive
    Else
        ActiveDropDownList = True
        Active "DropDownDataList", "A:A"    ' Active データーシート名, データーセル範囲
    End If
End Sub

' SheetModule

Option Explicit

Private ActiveDropDownList As Boolean

' ワークシートがアクティブになると実行される

Private Sub Worksheet_Activate()

GuessStatus ActiveCell

End Sub

' ワークシートが非アクティブになると実行される

Private Sub Worksheet_Deactivate()

ActiveDropDownList = False

Deactive

End Sub

' 選択されたセル範囲が変更されると実行される

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

GuessStatus Target

End Sub

' ワークシートの値が変更されると実行される

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

If KeyEventCallbackRunning Then Exit Sub

If ActiveDropDownList Then WorksheetOnChange Target

End Sub

Private Sub GuessStatus(Target As Object)

If Application.Intersect(Target, Range("Sheet1!B:B")) Is Nothing Then

ActiveDropDownList = False

Deactive

Else

ActiveDropDownList = True

Active "DropDownDataList", "A:A" ' Active データーシート名, データーセル範囲

End If

End Sub

FormDropDownList (Form Module) :

'
' FormModule
'

Option Explicit

Private Sub UserForm_Click()
    ' フォーカスを元のセルに戻す
    AppActivate Application.Caption
End Sub

Private Sub ListBox1_Click()
    ' フォーカスを元のセルに戻す
    AppActivate Application.Caption
End Sub

' ダブルクリックで決定
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    OnKeyCallback "RETURN"
End Sub

' FormModule

Option Explicit

Private Sub UserForm_Click()

' フォーカスを元のセルに戻す

AppActivate Application.Caption

End Sub

Private Sub ListBox1_Click()

' フォーカスを元のセルに戻す

AppActivate Application.Caption

End Sub

' ダブルクリックで決定

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

OnKeyCallback "RETURN"

End Sub

DropDownSuggestModule (Module) :

'
' DropDownSuggestModule
'

Option Explicit

Private mDataSheetName As String        ' 入力候補データーのシート
Private mDataRange As String            ' 入力候補データーのセル範囲

Public KeyEventCallbackRunning As Boolean

Private PrevActiveCell As Object


Public Sub Active(DataSheetName As String, DataRange As String)
    Debug.Print "Active DropDownSuggestModule"
    
    mDataSheetName = DataSheetName
    mDataRange = DataRange
    
    KeyEventCallbackRunning = False
    KeyEventOn
End Sub

Public Sub Deactive()
    Debug.Print "Deactive DropDownSuggestModule"
   
    KeyEventOff
    UserForm1_Unload
End Sub

Private Sub FormKeyEventOn()
    Application.OnKey "{ESC}", "'OnKeyCallback """ & "ESC" & """'"
    Application.OnKey "{UP}", "'OnKeyCallback """ & "UP" & """'"
    Application.OnKey "{DOWN}", "'OnKeyCallback """ & "DOWN" & """'"
    Application.OnKey "{RETURN}", "'OnKeyCallback """ & "RETURN" & """'"

    Application.OnKey "{LEFT}", "'OnKeyCallback """ & "LEFT" & """'"
    Application.OnKey "{RIGHT}", "'OnKeyCallback """ & "RIGHT" & """'"
End Sub

Private Sub FormKeyEventOff()
    Application.OnKey "{ESC}"
    Application.OnKey "{UP}"
    Application.OnKey "{DOWN}"
    Application.OnKey "{RETURN}"
    
    Application.OnKey "{LEFT}"
    Application.OnKey "{RIGHT}"
End Sub

Private Sub KeyEventOn()

    '
    Application.OnKey "{BS}", "'OnKeyCallback """ & "BS" & """'"
    Application.OnKey "{TAB}", "'OnKeyCallback """ & "TAB" & """'"
    
    ' 0 - 9
    Application.OnKey "{" & vbKey0 & "}", "'OnKeyCallback """ & "0" & """'"
    Application.OnKey "{" & vbKey1 & "}", "'OnKeyCallback """ & "1" & """'"
    Application.OnKey "{" & vbKey2 & "}", "'OnKeyCallback """ & "2" & """'"
    Application.OnKey "{" & vbKey3 & "}", "'OnKeyCallback """ & "3" & """'"
    Application.OnKey "{" & vbKey4 & "}", "'OnKeyCallback """ & "4" & """'"
    Application.OnKey "{" & vbKey5 & "}", "'OnKeyCallback """ & "5" & """'"
    Application.OnKey "{" & vbKey6 & "}", "'OnKeyCallback """ & "6" & """'"
    Application.OnKey "{" & vbKey7 & "}", "'OnKeyCallback """ & "7" & """'"
    Application.OnKey "{" & vbKey8 & "}", "'OnKeyCallback """ & "8" & """'"
    Application.OnKey "{" & vbKey9 & "}", "'OnKeyCallback """ & "9" & """'"


    ' 0 - 9
    Application.OnKey "{" & vbKeyNumpad0 & "}", "'OnKeyCallback """ & "0" & """'"
    Application.OnKey "{" & vbKeyNumpad1 & "}", "'OnKeyCallback """ & "1" & """'"
    Application.OnKey "{" & vbKeyNumpad2 & "}", "'OnKeyCallback """ & "2" & """'"
    Application.OnKey "{" & vbKeyNumpad3 & "}", "'OnKeyCallback """ & "3" & """'"
    Application.OnKey "{" & vbKeyNumpad4 & "}", "'OnKeyCallback """ & "4" & """'"
    Application.OnKey "{" & vbKeyNumpad5 & "}", "'OnKeyCallback """ & "5" & """'"
    Application.OnKey "{" & vbKeyNumpad6 & "}", "'OnKeyCallback """ & "6" & """'"
    Application.OnKey "{" & vbKeyNumpad7 & "}", "'OnKeyCallback """ & "7" & """'"
    Application.OnKey "{" & vbKeyNumpad8 & "}", "'OnKeyCallback """ & "8" & """'"
    Application.OnKey "{" & vbKeyNumpad9 & "}", "'OnKeyCallback """ & "9" & """'"


    ' A - Z
    Application.OnKey "a", "'OnKeyCallback """ & "a" & """'"
    Application.OnKey "b", "'OnKeyCallback """ & "b" & """'"
    Application.OnKey "c", "'OnKeyCallback """ & "c" & """'"
    Application.OnKey "d", "'OnKeyCallback """ & "d" & """'"
    Application.OnKey "e", "'OnKeyCallback """ & "e" & """'"
    Application.OnKey "f", "'OnKeyCallback """ & "f" & """'"
    Application.OnKey "g", "'OnKeyCallback """ & "g" & """'"
    Application.OnKey "h", "'OnKeyCallback """ & "h" & """'"
    Application.OnKey "i", "'OnKeyCallback """ & "i" & """'"
    Application.OnKey "j", "'OnKeyCallback """ & "j" & """'"
    Application.OnKey "k", "'OnKeyCallback """ & "k" & """'"
    Application.OnKey "l", "'OnKeyCallback """ & "l" & """'"
    Application.OnKey "m", "'OnKeyCallback """ & "m" & """'"
    Application.OnKey "n", "'OnKeyCallback """ & "n" & """'"
    Application.OnKey "o", "'OnKeyCallback """ & "o" & """'"
    Application.OnKey "p", "'OnKeyCallback """ & "p" & """'"
    Application.OnKey "q", "'OnKeyCallback """ & "q" & """'"
    Application.OnKey "r", "'OnKeyCallback """ & "r" & """'"
    Application.OnKey "s", "'OnKeyCallback """ & "s" & """'"
    Application.OnKey "t", "'OnKeyCallback """ & "t" & """'"
    Application.OnKey "u", "'OnKeyCallback """ & "u" & """'"
    Application.OnKey "v", "'OnKeyCallback """ & "v" & """'"
    Application.OnKey "w", "'OnKeyCallback """ & "w" & """'"
    Application.OnKey "x", "'OnKeyCallback """ & "x" & """'"
    Application.OnKey "y", "'OnKeyCallback """ & "y" & """'"
    Application.OnKey "z", "'OnKeyCallback """ & "z" & """'"


    ' A - Z
    Application.OnKey "A", "'OnKeyCallback """ & "A" & """'"
    Application.OnKey "B", "'OnKeyCallback """ & "B" & """'"
    Application.OnKey "C", "'OnKeyCallback """ & "C" & """'"
    Application.OnKey "D", "'OnKeyCallback """ & "D" & """'"
    Application.OnKey "E", "'OnKeyCallback """ & "E" & """'"
    Application.OnKey "F", "'OnKeyCallback """ & "F" & """'"
    Application.OnKey "G", "'OnKeyCallback """ & "G" & """'"
    Application.OnKey "H", "'OnKeyCallback """ & "H" & """'"
    Application.OnKey "I", "'OnKeyCallback """ & "I" & """'"
    Application.OnKey "J", "'OnKeyCallback """ & "J" & """'"
    Application.OnKey "K", "'OnKeyCallback """ & "K" & """'"
    Application.OnKey "L", "'OnKeyCallback """ & "L" & """'"
    Application.OnKey "M", "'OnKeyCallback """ & "M" & """'"
    Application.OnKey "N", "'OnKeyCallback """ & "N" & """'"
    Application.OnKey "O", "'OnKeyCallback """ & "O" & """'"
    Application.OnKey "P", "'OnKeyCallback """ & "P" & """'"
    Application.OnKey "Q", "'OnKeyCallback """ & "Q" & """'"
    Application.OnKey "R", "'OnKeyCallback """ & "R" & """'"
    Application.OnKey "S", "'OnKeyCallback """ & "S" & """'"
    Application.OnKey "T", "'OnKeyCallback """ & "T" & """'"
    Application.OnKey "U", "'OnKeyCallback """ & "U" & """'"
    Application.OnKey "V", "'OnKeyCallback """ & "V" & """'"
    Application.OnKey "W", "'OnKeyCallback """ & "W" & """'"
    Application.OnKey "X", "'OnKeyCallback """ & "X" & """'"
    Application.OnKey "Y", "'OnKeyCallback """ & "Y" & """'"
    Application.OnKey "Z", "'OnKeyCallback """ & "Z" & """'"

End Sub

Private Sub KeyEventOff()

    '
    Application.OnKey "{BS}"
    Application.OnKey "{TAB}"
    
    
    ' 0 - 9
    Application.OnKey "{" & vbKey0 & "}"
    Application.OnKey "{" & vbKey1 & "}"
    Application.OnKey "{" & vbKey2 & "}"
    Application.OnKey "{" & vbKey3 & "}"
    Application.OnKey "{" & vbKey4 & "}"
    Application.OnKey "{" & vbKey5 & "}"
    Application.OnKey "{" & vbKey6 & "}"
    Application.OnKey "{" & vbKey7 & "}"
    Application.OnKey "{" & vbKey8 & "}"
    Application.OnKey "{" & vbKey9 & "}"


    ' 0 - 9
    Application.OnKey "{" & vbKeyNumpad0 & "}"
    Application.OnKey "{" & vbKeyNumpad1 & "}"
    Application.OnKey "{" & vbKeyNumpad2 & "}"
    Application.OnKey "{" & vbKeyNumpad3 & "}"
    Application.OnKey "{" & vbKeyNumpad4 & "}"
    Application.OnKey "{" & vbKeyNumpad5 & "}"
    Application.OnKey "{" & vbKeyNumpad6 & "}"
    Application.OnKey "{" & vbKeyNumpad7 & "}"
    Application.OnKey "{" & vbKeyNumpad8 & "}"
    Application.OnKey "{" & vbKeyNumpad9 & "}"


    ' A - Z
    Application.OnKey "a"
    Application.OnKey "b"
    Application.OnKey "c"
    Application.OnKey "d"
    Application.OnKey "e"
    Application.OnKey "f"
    Application.OnKey "g"
    Application.OnKey "h"
    Application.OnKey "i"
    Application.OnKey "j"
    Application.OnKey "k"
    Application.OnKey "l"
    Application.OnKey "m"
    Application.OnKey "n"
    Application.OnKey "o"
    Application.OnKey "p"
    Application.OnKey "q"
    Application.OnKey "r"
    Application.OnKey "s"
    Application.OnKey "t"
    Application.OnKey "u"
    Application.OnKey "v"
    Application.OnKey "w"
    Application.OnKey "x"
    Application.OnKey "y"
    Application.OnKey "z"


    ' A - Z
    Application.OnKey "A"
    Application.OnKey "B"
    Application.OnKey "C"
    Application.OnKey "D"
    Application.OnKey "E"
    Application.OnKey "F"
    Application.OnKey "G"
    Application.OnKey "H"
    Application.OnKey "I"
    Application.OnKey "J"
    Application.OnKey "K"
    Application.OnKey "L"
    Application.OnKey "M"
    Application.OnKey "N"
    Application.OnKey "O"
    Application.OnKey "P"
    Application.OnKey "Q"
    Application.OnKey "R"
    Application.OnKey "S"
    Application.OnKey "T"
    Application.OnKey "U"
    Application.OnKey "V"
    Application.OnKey "W"
    Application.OnKey "X"
    Application.OnKey "Y"
    Application.OnKey "Z"

End Sub

Public Sub OnKeyCallback(ByVal KeyStr As String)
    On Error GoTo ErrorHandler

    KeyEventCallbackRunning = True
        
    Dim aCell As Object
    
    ' Debug.Print "OnKeyCallback: " & KeyStr
    
    Set aCell = ActiveCell
    If aCell.Count > 1 Then Exit Sub ' 複数セル?
   
    If KeyStr = "ESC" Then
        UserForm1_Unload
        KeyEventCallbackRunning = False
        Exit Sub
    ElseIf KeyStr = "DOWN" Then
        ' Debug.Print "FormDropDownList.ListBox1.ListCount: " & FormDropDownList.ListBox1.ListCount & ", " & itemIndex & ", " & FormDropDownList.ListBox1.ListIndex
        If FormDropDownList.ListBox1.ListIndex < FormDropDownList.ListBox1.ListCount - 1 Then FormDropDownList.ListBox1.ListIndex = FormDropDownList.ListBox1.ListIndex + 1
    ElseIf KeyStr = "UP" Then
        If FormDropDownList.ListBox1.ListIndex > 0 Then FormDropDownList.ListBox1.ListIndex = FormDropDownList.ListBox1.ListIndex - 1
    ElseIf KeyStr = "RETURN" Then
        If FormDropDownList.ListBox1.ListIndex >= 0 Then aCell.Value = FormDropDownList.ListBox1.Value
        UserForm1_Unload
        aCell.Offset(1, 0).Activate ' 1個下のセルに移動
        KeyEventCallbackRunning = False
        Exit Sub
    ElseIf KeyStr = "BS" Then
        aCell.Value = Mid(aCell.Value, 1, Len(aCell.Value) - 1) ' Remove last letter
        SetListItem aCell.Value
    ElseIf KeyStr = "TAB" Then
    ElseIf KeyStr = "LEFT" Then
    ElseIf KeyStr = "RIGHT" Then
        ' 何もしない
    Else
        If PrevActiveCell Is Nothing Then       ' 初めての入力
            aCell.Value = KeyStr
        ElseIf PrevActiveCell <> aCell Then     ' 入力対象のセルが前回とは異なる
            aCell.Value = KeyStr
        Else
            aCell.Value = aCell.Value & KeyStr  ' 前回と同一のセルへの入力なので入力された文字を追加する
        End If
            
        SetListItem aCell.Value
       
        Set PrevActiveCell = aCell
    End If
    
    UserForm1_Show aCell  ' 入力候補 Form を表示する
    KeyEventCallbackRunning = False

ErrorHandler:
    KeyEventCallbackRunning = False
    Debug.Print "DropDownSuggestModule.WorksheetOnChange: " & "" & Err.Number & ": " & Err.Description
End Sub


' Sheet コードから呼び出す: "Private Sub Worksheet_Change(ByVal Target As Excel.Range)"
'
Public Sub WorksheetOnChange(Cell As Object)
    On Error GoTo ErrorHandler

    If Cell.Count > 1 Then Exit Sub ' 複数セル?
    
    UserForm1_Show Cell
    SetListItem Cell.Value
    
    ' 編集対象のセルに戻す
    Cell.Activate
    ' Cell.Select   ' またはこの方法?
    
ErrorHandler:
    Debug.Print "DropDownSuggestModule.WorksheetOnChange: " & "" & Err.Number & ": " & Err.Description
End Sub


Private Sub UserForm1_Show(Cell As Object)

    Dim pox#, poy#  ' Form を表示する座標

    If Not FormDropDownList.ActiveControl Is Nothing Then
        Exit Sub    ' Form は既に表示している
    End If
    
    FormDropDownList.Show vbModeless
    ' RemoveTitleBar UserForm1

    If Not kPosCell(FormDropDownList, pox, poy, Cell.Offset(1, 0)) = -1 Then   ' 下のセルを基準に座標を求める
        If poy < 500 Then
            FormDropDownList.Top = poy
            FormDropDownList.Left = pox
        Else
            FormDropDownList.Top = poy - FormDropDownList.Height - Cell.Height * ActiveWindow.Zoom / 100
            FormDropDownList.Left = pox
        End If
    End If
    
    ' Form を表示した後でフォーカスを元のセルに戻す
    ' aCell.Activate ' 効果なし
    ' aCell.Select   ' 効果なし
    ' Application.Visible = True ' これか次の方法で OK な模様
    AppActivate Application.Caption
    
    FormKeyEventOn
End Sub


Private Sub UserForm1_Unload()
    Unload FormDropDownList    ' From を非表示にする 表示／非表示を Nothing で判定できるように Unload する
    FormKeyEventOff
    Set PrevActiveCell = Nothing
End Sub

'
' See: https://language-and-engineering.hatenablog.jp/entry/20081125/1227571724
'
Private Sub SetListItem(matchKey As String)
    Dim listSheet As String     ' "候補データ"  ' 検索対象シート
    Dim strDictionary As String ' "A:A"       ' 検索対象範囲
    
    listSheet = mDataSheetName  ' "候補データ"  ' 検索対象シート
    strDictionary = mDataRange  ' "A:A"       ' 検索対象範囲
    
    Dim foundCell As Variant
    Dim firstAddress As String  ' 最初の結果のアドレス
    Dim lngY As Long, intX As Long
    Dim matchWord As String

    ' If Tg.Count > 1 Then Exit Sub ' セル結合?
    
    FormDropDownList.ListBox1.Clear

    ' 部分一致で検索する（完全一致での検索を回避）
    Set foundCell = Worksheets(listSheet).Range(strDictionary).Find(What:=matchKey, LookAt:=xlPart)
    
    If foundCell Is Nothing Then Exit Sub   ' 検索結果なし
    
    ' 検索結果を回す
    firstAddress = foundCell.Address
    Do
        ' 辞書から入力候補を収集
        lngY = foundCell.Cells.Row
        intX = foundCell.Cells.Column
        matchWord = Worksheets(listSheet).Cells(lngY, intX).Value

        '比較
        If InStr(matchWord, matchKey) > 0 Then
            FormDropDownList.ListBox1.AddItem matchWord
        End If

        ' 次の入力候補へ
        Set foundCell = Worksheets(listSheet).Range(strDictionary).FindNext(foundCell)
    
    Loop While (Not foundCell Is Nothing) And (firstAddress <> foundCell.Address)
    
    ' リストアイテムが存在するなら先頭を選択状態にする
    If FormDropDownList.ListBox1.ListCount > 0 Then FormDropDownList.ListBox1.ListIndex = 0

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

' DropDownSuggestModule

Option Explicit

Private mDataSheetName As String ' 入力候補データーのシート

Private mDataRange As String ' 入力候補データーのセル範囲

Public KeyEventCallbackRunning As Boolean

Private PrevActiveCell As Object

Public Sub Active(DataSheetName As String, DataRange As String)

Debug.Print "Active DropDownSuggestModule"

mDataSheetName = DataSheetName

mDataRange = DataRange

KeyEventCallbackRunning = False

KeyEventOn

End Sub

Public Sub Deactive()

Debug.Print "Deactive DropDownSuggestModule"

KeyEventOff

UserForm1_Unload

End Sub

Private Sub FormKeyEventOn()

Application.OnKey "{ESC}", "'OnKeyCallback """ & "ESC" & """'"

Application.OnKey "{UP}", "'OnKeyCallback """ & "UP" & """'"

Application.OnKey "{DOWN}", "'OnKeyCallback """ & "DOWN" & """'"

Application.OnKey "{RETURN}", "'OnKeyCallback """ & "RETURN" & """'"

Application.OnKey "{LEFT}", "'OnKeyCallback """ & "LEFT" & """'"

Application.OnKey "{RIGHT}", "'OnKeyCallback """ & "RIGHT" & """'"

End Sub

Private Sub FormKeyEventOff()

Application.OnKey "{ESC}"

Application.OnKey "{UP}"

Application.OnKey "{DOWN}"

Application.OnKey "{RETURN}"

Application.OnKey "{LEFT}"

Application.OnKey "{RIGHT}"

End Sub

Private Sub KeyEventOn()

Application.OnKey "{BS}", "'OnKeyCallback """ & "BS" & """'"

Application.OnKey "{TAB}", "'OnKeyCallback """ & "TAB" & """'"

' 0 - 9

Application.OnKey "{" & vbKey0 & "}", "'OnKeyCallback """ & "0" & """'"

Application.OnKey "{" & vbKey1 & "}", "'OnKeyCallback """ & "1" & """'"

Application.OnKey "{" & vbKey2 & "}", "'OnKeyCallback """ & "2" & """'"

Application.OnKey "{" & vbKey3 & "}", "'OnKeyCallback """ & "3" & """'"

Application.OnKey "{" & vbKey4 & "}", "'OnKeyCallback """ & "4" & """'"

Application.OnKey "{" & vbKey5 & "}", "'OnKeyCallback """ & "5" & """'"

Application.OnKey "{" & vbKey6 & "}", "'OnKeyCallback """ & "6" & """'"

Application.OnKey "{" & vbKey7 & "}", "'OnKeyCallback """ & "7" & """'"

Application.OnKey "{" & vbKey8 & "}", "'OnKeyCallback """ & "8" & """'"

Application.OnKey "{" & vbKey9 & "}", "'OnKeyCallback """ & "9" & """'"

' 0 - 9

Application.OnKey "{" & vbKeyNumpad0 & "}", "'OnKeyCallback """ & "0" & """'"

Application.OnKey "{" & vbKeyNumpad1 & "}", "'OnKeyCallback """ & "1" & """'"

Application.OnKey "{" & vbKeyNumpad2 & "}", "'OnKeyCallback """ & "2" & """'"

Application.OnKey "{" & vbKeyNumpad3 & "}", "'OnKeyCallback """ & "3" & """'"

Application.OnKey "{" & vbKeyNumpad4 & "}", "'OnKeyCallback """ & "4" & """'"

Application.OnKey "{" & vbKeyNumpad5 & "}", "'OnKeyCallback """ & "5" & """'"

Application.OnKey "{" & vbKeyNumpad6 & "}", "'OnKeyCallback """ & "6" & """'"

Application.OnKey "{" & vbKeyNumpad7 & "}", "'OnKeyCallback """ & "7" & """'"

Application.OnKey "{" & vbKeyNumpad8 & "}", "'OnKeyCallback """ & "8" & """'"

Application.OnKey "{" & vbKeyNumpad9 & "}", "'OnKeyCallback """ & "9" & """'"

' A - Z

Application.OnKey "a", "'OnKeyCallback """ & "a" & """'"

Application.OnKey "b", "'OnKeyCallback """ & "b" & """'"

Application.OnKey "c", "'OnKeyCallback """ & "c" & """'"

Application.OnKey "d", "'OnKeyCallback """ & "d" & """'"

Application.OnKey "e", "'OnKeyCallback """ & "e" & """'"

Application.OnKey "f", "'OnKeyCallback """ & "f" & """'"

Application.OnKey "g", "'OnKeyCallback """ & "g" & """'"

Application.OnKey "h", "'OnKeyCallback """ & "h" & """'"

Application.OnKey "i", "'OnKeyCallback """ & "i" & """'"

Application.OnKey "j", "'OnKeyCallback """ & "j" & """'"

Application.OnKey "k", "'OnKeyCallback """ & "k" & """'"

Application.OnKey "l", "'OnKeyCallback """ & "l" & """'"

Application.OnKey "m", "'OnKeyCallback """ & "m" & """'"

Application.OnKey "n", "'OnKeyCallback """ & "n" & """'"

Application.OnKey "o", "'OnKeyCallback """ & "o" & """'"

Application.OnKey "p", "'OnKeyCallback """ & "p" & """'"

Application.OnKey "q", "'OnKeyCallback """ & "q" & """'"

Application.OnKey "r", "'OnKeyCallback """ & "r" & """'"

Application.OnKey "s", "'OnKeyCallback """ & "s" & """'"

Application.OnKey "t", "'OnKeyCallback """ & "t" & """'"

Application.OnKey "u", "'OnKeyCallback """ & "u" & """'"

Application.OnKey "v", "'OnKeyCallback """ & "v" & """'"

Application.OnKey "w", "'OnKeyCallback """ & "w" & """'"

Application.OnKey "x", "'OnKeyCallback """ & "x" & """'"

Application.OnKey "y", "'OnKeyCallback """ & "y" & """'"

Application.OnKey "z", "'OnKeyCallback """ & "z" & """'"

' A - Z

Application.OnKey "A", "'OnKeyCallback """ & "A" & """'"

Application.OnKey "B", "'OnKeyCallback """ & "B" & """'"

Application.OnKey "C", "'OnKeyCallback """ & "C" & """'"

Application.OnKey "D", "'OnKeyCallback """ & "D" & """'"

Application.OnKey "E", "'OnKeyCallback """ & "E" & """'"

Application.OnKey "F", "'OnKeyCallback """ & "F" & """'"

Application.OnKey "G", "'OnKeyCallback """ & "G" & """'"

Application.OnKey "H", "'OnKeyCallback """ & "H" & """'"

Application.OnKey "I", "'OnKeyCallback """ & "I" & """'"

Application.OnKey "J", "'OnKeyCallback """ & "J" & """'"

Application.OnKey "K", "'OnKeyCallback """ & "K" & """'"

Application.OnKey "L", "'OnKeyCallback """ & "L" & """'"

Application.OnKey "M", "'OnKeyCallback """ & "M" & """'"

Application.OnKey "N", "'OnKeyCallback """ & "N" & """'"

Application.OnKey "O", "'OnKeyCallback """ & "O" & """'"

Application.OnKey "P", "'OnKeyCallback """ & "P" & """'"

Application.OnKey "Q", "'OnKeyCallback """ & "Q" & """'"

Application.OnKey "R", "'OnKeyCallback """ & "R" & """'"

Application.OnKey "S", "'OnKeyCallback """ & "S" & """'"

Application.OnKey "T", "'OnKeyCallback """ & "T" & """'"

Application.OnKey "U", "'OnKeyCallback """ & "U" & """'"

Application.OnKey "V", "'OnKeyCallback """ & "V" & """'"

Application.OnKey "W", "'OnKeyCallback """ & "W" & """'"

Application.OnKey "X", "'OnKeyCallback """ & "X" & """'"

Application.OnKey "Y", "'OnKeyCallback """ & "Y" & """'"

Application.OnKey "Z", "'OnKeyCallback """ & "Z" & """'"

End Sub

Private Sub KeyEventOff()

Application.OnKey "{BS}"

Application.OnKey "{TAB}"

' 0 - 9

Application.OnKey "{" & vbKey0 & "}"

Application.OnKey "{" & vbKey1 & "}"

Application.OnKey "{" & vbKey2 & "}"

Application.OnKey "{" & vbKey3 & "}"

Application.OnKey "{" & vbKey4 & "}"

Application.OnKey "{" & vbKey5 & "}"

Application.OnKey "{" & vbKey6 & "}"

Application.OnKey "{" & vbKey7 & "}"

Application.OnKey "{" & vbKey8 & "}"

Application.OnKey "{" & vbKey9 & "}"

' 0 - 9

Application.OnKey "{" & vbKeyNumpad0 & "}"

Application.OnKey "{" & vbKeyNumpad1 & "}"

Application.OnKey "{" & vbKeyNumpad2 & "}"

Application.OnKey "{" & vbKeyNumpad3 & "}"

Application.OnKey "{" & vbKeyNumpad4 & "}"

Application.OnKey "{" & vbKeyNumpad5 & "}"

Application.OnKey "{" & vbKeyNumpad6 & "}"

Application.OnKey "{" & vbKeyNumpad7 & "}"

Application.OnKey "{" & vbKeyNumpad8 & "}"

Application.OnKey "{" & vbKeyNumpad9 & "}"

' A - Z

Application.OnKey "a"

Application.OnKey "b"

Application.OnKey "c"

Application.OnKey "d"

Application.OnKey "e"

Application.OnKey "f"

Application.OnKey "g"

Application.OnKey "h"

Application.OnKey "i"

Application.OnKey "j"

Application.OnKey "k"

Application.OnKey "l"

Application.OnKey "m"

Application.OnKey "n"

Application.OnKey "o"

Application.OnKey "p"

Application.OnKey "q"

Application.OnKey "r"

Application.OnKey "s"

Application.OnKey "t"

Application.OnKey "u"

Application.OnKey "v"

Application.OnKey "w"

Application.OnKey "x"

Application.OnKey "y"

Application.OnKey "z"

' A - Z

Application.OnKey "A"

Application.OnKey "B"

Application.OnKey "C"

Application.OnKey "D"

Application.OnKey "E"

Application.OnKey "F"

Application.OnKey "G"

Application.OnKey "H"

Application.OnKey "I"

Application.OnKey "J"

Application.OnKey "K"

Application.OnKey "L"

Application.OnKey "M"

Application.OnKey "N"

Application.OnKey "O"

Application.OnKey "P"

Application.OnKey "Q"

Application.OnKey "R"

Application.OnKey "S"

Application.OnKey "T"

Application.OnKey "U"

Application.OnKey "V"

Application.OnKey "W"

Application.OnKey "X"

Application.OnKey "Y"

Application.OnKey "Z"

End Sub

Public Sub OnKeyCallback(ByVal KeyStr As String)

On Error GoTo ErrorHandler

KeyEventCallbackRunning = True

Dim aCell As Object

' Debug.Print "OnKeyCallback: " & KeyStr

Set aCell = ActiveCell

If aCell.Count > 1 Then Exit Sub ' 複数セル?

If KeyStr = "ESC" Then

UserForm1_Unload

KeyEventCallbackRunning = False

Exit Sub

ElseIf KeyStr = "DOWN" Then

' Debug.Print "FormDropDownList.ListBox1.ListCount: " & FormDropDownList.ListBox1.ListCount & ", " & itemIndex & ", " & FormDropDownList.ListBox1.ListIndex

If FormDropDownList.ListBox1.ListIndex < FormDropDownList.ListBox1.ListCount - 1 Then FormDropDownList.ListBox1.ListIndex = FormDropDownList.ListBox1.ListIndex + 1

ElseIf KeyStr = "UP" Then

If FormDropDownList.ListBox1.ListIndex > 0 Then FormDropDownList.ListBox1.ListIndex = FormDropDownList.ListBox1.ListIndex - 1

ElseIf KeyStr = "RETURN" Then

If FormDropDownList.ListBox1.ListIndex >= 0 Then aCell.Value = FormDropDownList.ListBox1.Value

UserForm1_Unload

aCell.Offset(1, 0).Activate ' 1個下のセルに移動

KeyEventCallbackRunning = False

Exit Sub

ElseIf KeyStr = "BS" Then

aCell.Value = Mid(aCell.Value, 1, Len(aCell.Value) - 1) ' Remove last letter

SetListItem aCell.Value

ElseIf KeyStr = "TAB" Then

ElseIf KeyStr = "LEFT" Then

ElseIf KeyStr = "RIGHT" Then

' 何もしない

Else

If PrevActiveCell Is Nothing Then ' 初めての入力

aCell.Value = KeyStr

ElseIf PrevActiveCell <> aCell Then ' 入力対象のセルが前回とは異なる

aCell.Value = KeyStr

Else

aCell.Value = aCell.Value & KeyStr ' 前回と同一のセルへの入力なので入力された文字を追加する

End If

SetListItem aCell.Value

Set PrevActiveCell = aCell

End If

UserForm1_Show aCell ' 入力候補 Form を表示する

KeyEventCallbackRunning = False

ErrorHandler:

KeyEventCallbackRunning = False

Debug.Print "DropDownSuggestModule.WorksheetOnChange: " & "" & Err.Number & ": " & Err.Description

End Sub

' Sheet コードから呼び出す: "Private Sub Worksheet_Change(ByVal Target As Excel.Range)"

Public Sub WorksheetOnChange(Cell As Object)

On Error GoTo ErrorHandler

If Cell.Count > 1 Then Exit Sub ' 複数セル?

UserForm1_Show Cell

SetListItem Cell.Value

' 編集対象のセルに戻す

Cell.Activate

' Cell.Select ' またはこの方法?

ErrorHandler:

Debug.Print "DropDownSuggestModule.WorksheetOnChange: " & "" & Err.Number & ": " & Err.Description

End Sub

Private Sub UserForm1_Show(Cell As Object)

Dim pox#, poy# ' Form を表示する座標

If Not FormDropDownList.ActiveControl Is Nothing Then

Exit Sub ' Form は既に表示している

End If

FormDropDownList.Show vbModeless

' RemoveTitleBar UserForm1

If Not kPosCell(FormDropDownList, pox, poy, Cell.Offset(1, 0)) = -1 Then ' 下のセルを基準に座標を求める

If poy < 500 Then

FormDropDownList.Top = poy

FormDropDownList.Left = pox

Else

FormDropDownList.Top = poy - FormDropDownList.Height - Cell.Height * ActiveWindow.Zoom / 100

FormDropDownList.Left = pox

End If

' Form を表示した後でフォーカスを元のセルに戻す

' aCell.Activate ' 効果なし

' aCell.Select ' 効果なし

' Application.Visible = True ' これか次の方法で OK な模様

AppActivate Application.Caption

FormKeyEventOn

End Sub

Private Sub UserForm1_Unload()

Unload FormDropDownList ' From を非表示にする表示／非表示を Nothing で判定できるように Unload する

FormKeyEventOff

Set PrevActiveCell = Nothing

End Sub

' See: https://language-and-engineering.hatenablog.jp/entry/20081125/1227571724

Private Sub SetListItem(matchKey As String)

Dim listSheet As String ' "候補データ" ' 検索対象シート

Dim strDictionary As String ' "A:A" ' 検索対象範囲

listSheet = mDataSheetName ' "候補データ" ' 検索対象シート

strDictionary = mDataRange ' "A:A" ' 検索対象範囲

Dim foundCell As Variant

Dim firstAddress As String ' 最初の結果のアドレス

Dim lngY As Long, intX As Long

Dim matchWord As String

' If Tg.Count > 1 Then Exit Sub ' セル結合?

FormDropDownList.ListBox1.Clear

' 部分一致で検索する（完全一致での検索を回避）

Set foundCell = Worksheets(listSheet).Range(strDictionary).Find(What:=matchKey, LookAt:=xlPart)

If foundCell Is Nothing Then Exit Sub ' 検索結果なし

' 検索結果を回す

firstAddress = foundCell.Address

' 辞書から入力候補を収集

lngY = foundCell.Cells.Row

intX = foundCell.Cells.Column

matchWord = Worksheets(listSheet).Cells(lngY, intX).Value

'比較

If InStr(matchWord, matchKey) > 0 Then

FormDropDownList.ListBox1.AddItem matchWord

End If

' 次の入力候補へ

Set foundCell = Worksheets(listSheet).Range(strDictionary).FindNext(foundCell)

Loop While (Not foundCell Is Nothing) And (firstAddress <> foundCell.Address)

' リストアイテムが存在するなら先頭を選択状態にする

If FormDropDownList.ListBox1.ListCount > 0 Then FormDropDownList.ListBox1.ListIndex = 0

End Sub

GeneralModule (Module) :

'
' GeneralModule
'

Option Explicit

' kPosCell 関数 - http://www2.aqua-r.tepm.jp/~kmado/ke13u009.html
'
' セルのスクリーン座標を取得します ポイント単位
' 引数:
'   userForm ユーザーフォーム
'   psx, poy セル座標
'   pos セル位置 (既定値は ActiveCell の右下)
'   kx, ky ポイント・ピクセル変換係数
' 戻り値:
'    0 = 成功
'   -1 = 未対応
'
Function kPosCell(UserForm As Object, ByRef pox#, ByRef poy#, Optional pos As Range, _
    Optional ByRef kx#, Optional ByRef ky#) As Long
    
    ' 未対応 Return -1
    If ActiveWindow.Panes.Count > 1 Then kPosCell = -1: Exit Function
    
    Dim zx#, zy#, pxx&, pxy&, pxx1&, pxy1&
    Dim ww&, hh&, deskw&, deskh&, ia As IAccessible
    
    Set ia = UserForm
    ia.accParent.accLocation 0, 0, ww, hh
    kx = UserForm.Width / ww
    ky = UserForm.Height / hh
    
    If pos Is Nothing Then Set pos = ActiveCell.Offset(1, 1) ' 右下のセルを求める座標の基準にする
    
    With ActiveWindow
        pxy = pos.Height / kx
        pxy1 = pxy * .Zoom / 100
        zy = pxy1 / pxy
        pxx = pos.Width / ky
        pxx1 = pxx * .Zoom / 100
        zx = pxx1 / pxx
        pox = ky * .PointsToScreenPixelsX(0) + pos.Left * zx
        poy = kx * .PointsToScreenPixelsY(0) + pos.Top * zy
    End With
End Function

' GeneralModule

Option Explicit

' kPosCell 関数 - http://www2.aqua-r.tepm.jp/~kmado/ke13u009.html

' セルのスクリーン座標を取得しますポイント単位

' 引数:

' userForm ユーザーフォーム

' psx, poy セル座標

' pos セル位置 (既定値は ActiveCell の右下)

' kx, ky ポイント・ピクセル変換係数

' 戻り値:

' 0 = 成功

' -1 = 未対応

Function kPosCell(UserForm As Object, ByRef pox#, ByRef poy#, Optional pos As Range, _

Optional ByRef kx#, Optional ByRef ky#) As Long

' 未対応 Return -1

If ActiveWindow.Panes.Count > 1 Then kPosCell = -1: Exit Function

Dim zx#, zy#, pxx&, pxy&, pxx1&, pxy1&

Dim ww&, hh&, deskw&, deskh&, ia As IAccessible

Set ia = UserForm

ia.accParent.accLocation 0, 0, ww, hh

kx = UserForm.Width / ww

ky = UserForm.Height / hh

If pos Is Nothing Then Set pos = ActiveCell.Offset(1, 1) ' 右下のセルを求める座標の基準にする

With ActiveWindow

pxy = pos.Height / kx

pxy1 = pxy * .Zoom / 100

zy = pxy1 / pxy

pxx = pos.Width / ky

pxx1 = pxx * .Zoom / 100

zx = pxx1 / pxx

pox = ky * .PointsToScreenPixelsX(0) + pos.Left * zx

poy = kx * .PointsToScreenPixelsY(0) + pos.Top * zy

End With

End Function

カテゴリー: Excel

エクセルで、ハイパーリンクのアドレスを一括変更 / Replace the address of hyperlink all at once with Excel

まず、開発メニューを表示する

対象のシートモジュールに貼って実行

参照

エクセルで入力候補を表示してみる / Drop-down suggest list for entering cells in Excel sheet