【Excel】住所を検索するフォーム

Описание: 今回のコードです。
■シートのコード
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim 列 As String
Dim w As String

If イベントフラグ = False Then
If UserForm1.Visible = True Then
列 = Split(Target.Address, "$")(1)
w = StrConv(Target.Value, vbNarrow)
If (列 = con入力郵便列 Or 列 = con入力住所列) And _
w ＜＞ "" And _
(Len(w) ＜= 7 Or InStr(w, " ") ＞ 0) Then
Target.Select
UserForm1.TextBox1.Value = Replace(w, "-", "")
AppActivate UserForm1.Caption
Call UserForm1.検索
End If
End If
End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim 列 As String

If UserForm1.Visible = True Then
列 = Split(Target.Address, "$")(1)
If 列 = con入力郵便列 Or 列 = con入力住所列 Then
Call UserForm1.フォーム位置
End If
End If
End Sub

■フォームのコード

Option Explicit

Private c入力郵便列 As Long
Private c入力住所列 As Long
Private c元郵便番号列 As Long
Private c元住所列1 As Long
Private c元住所列2 As Long
Private c元住所列3 As Long

Private Sub UserForm_Activate()
Call 初期化
End Sub

Sub 初期化()

Dim i As Long
Dim wRange As Range

Me.TextBox1.Value = ""
Me.TextBox1.Font.Size = 16
Me.ListBox1.Clear
Me.ListBox1.Font.Size = 11
Me.ListBox1.ColumnCount = 2
Me.ListBox1.ColumnWidths = "60;200"
Me.Caption = "郵便番号又は住所を入力してください"
Call フォーム位置

c入力郵便列 = Columns(con入力郵便列).Column
c入力住所列 = Columns(con入力住所列).Column
c元郵便番号列 = Columns(con元郵便番号列).Column
c元住所列1 = Columns(con元住所列1).Column
c元住所列2 = Columns(con元住所列2).Column
c元住所列3 = Columns(con元住所列3).Column

If (Not 元データ) = -1 Then
Call 元データ取得
End If

End Sub

Sub 元データ取得()

Dim w元データ() As String
Dim var元データ As Variant
Dim 行 As Long
Dim 最終行 As Long
Dim 最終列 As Long
Dim w As String

With Worksheets(con元シート)

最終行 = .Cells(Rows.Count, c元郵便番号列).End(xlUp).Row
最終列 = .Cells(1, Columns.Count).End(xlToLeft).Column
var元データ = .Range(.Cells(1, 1), .Cells(最終行, 最終列))
ReDim w元データ(1 To 最終行)

For 行 = LBound(var元データ) To UBound(var元データ)
w = var元データ(行, c元郵便番号列) & _
var元データ(行, c元住所列1) & _
var元データ(行, c元住所列2) & _
var元データ(行, c元住所列3)
w = StrConv(w, vbWide)
w = Replace(w, "以下に掲載がない場合", "")
w元データ(行) = w
Next 行

End With

元データ = w元データ

End Sub

Sub フォーム位置()

Dim x As Double
Dim y As Double

'アクティブセルの下にする
With ActiveWindow
x = .PointsToScreenPixelsX(0) / 96 * 72 + ActiveCell.Left * .Zoom / 100
y = .PointsToScreenPixelsY(0) / 96 * 72 + ActiveCell.Offset(1, 0).Top * .Zoom / 100
End With
With UserForm1
.StartUpPosition = 0
.Left = x
.Top = y + 5
End With
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
Call 検索
End If
End Sub

Sub 検索()

Dim 入力文字 As String
Dim r郵便 As Long
Dim i As Long
Dim w検索対象 As String
Dim 単語 As Variant
Dim 候補1() As String
Dim 候補2 As Variant
Dim var As Variant
Dim flg As Boolean

入力文字 = Trim(TextBox1.Value)
If 入力文字 = "" Then
Exit Sub
End If

ReDim 候補1(1 To UBound(元データ))

i = 0
For r郵便 = LBound(元データ) To UBound(元データ)

w検索対象 = 元データ(r郵便)
flg = True
var = Split(StrConv(入力文字, vbWide), "　")
For Each 単語 In var
If InStr(1, w検索対象, 単語, vbTextCompare) = 0 Then
flg = False
Exit For
End If
Next

If flg = True Then
i = i + 1
候補1(i) = 元データ(r郵便)
End If

Next r郵便

If i = 0 Then
ListBox1.Clear
SendKeys "{TAB}"
Exit Sub
End If

ReDim 候補2(1 To i, 0 To 1)
For i = LBound(候補1) To UBound(候補1)
If 候補1(i) = "" Then
Exit For
End If
候補2(i, 0) = StrConv(Left(候補1(i), 3) & "-" & Mid(候補1(i), 4, 4), vbNarrow)
候補2(i, 1) = Mid(候補1(i), 8, Len(候補1(i)))
Next i

With ListBox1
.Clear
.List = 候補2
End With
End Sub

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
Call セルに反映
KeyCode = 0
End If
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call セルに反映
End Sub

Sub セルに反映()

Dim 行 As Long

イベントフラグ = True

If ListBox1.ListCount = 0 Then
Exit Sub
End If

行 = ActiveCell.Row
With ListBox1
Cells(行, c入力郵便列).Value = .List(.ListIndex, 0)
Cells(行, c入力住所列).Value = .List(.ListIndex, 1)
End With

Me.TextBox1.Value = ""
Me.ListBox1.Clear

Cells(行, c入力住所列).Select
AppActivate Application.Caption
If IMEStatus = vbIMEModeOff Then
SendKeys "{kanji}"
End If
SendKeys "{F2}"
AppActivate Application.Caption

イベントフラグ = False

End Sub

■標準モジュール

Option Explicit

Public Const con入力シート As String = "Sheet1"
Public Const con入力郵便列 As String = "B"
Public Const con入力住所列 As String = "C"
Public Const con元シート As String = "元データ"
Public Const con元郵便番号列 As String = "C"
Public Const con元住所列1 As String = "G"
Public Const con元住所列2 As String = "H"
Public Const con元住所列3 As String = "I"
Public 元データ() As String
Public イベントフラグ As Boolean

Sub フォーム表示()
UserForm1.Show vbModeless
End Sub