VBA Excel 名簿を検索

質問

Excel2013です。

別シートに名簿、作業用シートで名前を検索する、別シートにある名簿から検索された名前を選択すると、その名前の住所や電話番号が作業用シートに表示出来るようにしたいのですが、どなたかVBに詳しい方教えて下さい。
出来れば、名簿に無い場合は新規に登録出来たり、変更があったりしたら編集も出来て、重複してる場合は削除などが出来ればいいのですが。

回答No.4

eden3616

度重なり申し訳ありません。

先ほどの回答に追記しておけばよかったのですが、
作業用シートにオートシェイプで「実行」や「検索」などを作成し、マクロを登録することで
入力→オートシェイプクリックでマクロを実行できるため、より手軽にご利用できるかと思います。

（作業用シートを印刷するとのことですので、
　印刷設定を印刷しないにすると良いと思います）

http://www.konomiti.com/vba01_1.html
→ボタンからマクロを実行できるようにする。（マクロの登録）

が参考になるかと思います。

今回のマクロは
No2の添付画像にありますとおり、「*いか」で検索しますと「すいか」のようにワイルドカード検索（「*」を用いた検索）が行えます。

現状においてワイルドカードで複数一致する名前がある場合、一番初めに一致するものしか検索されない問題点があります。
（「*いか」でワイルドカード検索をした場合、「すいか」「するめいか」などが名簿にあると一致対象となりますが、今回のコードでは初めにヒットする「すいか」の行しか取得されません。）

おまけ機能の「del」を入れることで指定行の削除は、ワイルドカード検索を行った場合適用されません。

回答No.3

eden3616

>作業用のシートを作成した後はプリントアウトします。
>名前と住所そして電話番号を入力しなければいけない書類なので、
>名前を検索してなるべく入力しなくても作成出来るようにしたいと考えてます。

そのご利用方法でしたら、「名簿」シートをNo2の添付画像のような様式で作成して頂き
以下の箇所を変更して頂ければご利用できると思います。

Set tar(0) = Sheets("作業用シート")
col1 = Split("A2,B2,C2", ",")
Set tar(1) = Sheets("名簿")

>名前を検索して登録されて無ければ、ついでに登録出来たら、
>次に作成する人は楽になると考えました。
>教えていただいたコードを参考に試してみます。

不都合あれば調整致しますので問題点、動作状況、目的等をご提示ください。

回答No.2

eden3616

No1の解説になります。

■VBAコードの追加方法
(1)Alt+F11で「Microsoft Visual Vasic」を開きます
(2)「挿入→標準モジュール」で新規モジュールを作成
(3)作成されたモジュールにNo1のVBAコードを全て貼り付けてください

現在の設定では添付画像のような様式で動作いたします。
（ただし、作業用シートと名簿のシートは同じブック内である必要があります）

★★★★★★必ず！★★★★★
いきなり本番で利用せず、画像のサンプルデータと同じものを作成のうえ、動作確認お願いします

■基本的な使い方
(1)「作業用シート」のセル「A2」に検索したい名前を入力
(2)エクセルメニューの表示→マクロ→「取得」を実行
(3)「名簿」シートの「A」列を検索し一致した場合の住所と電話を「作業用シート」のセル「B2」「B3」に表示されます
(4)一致しなかった場合は確認のダイアログが表示され、新規追加処理にうつります。

■新規追加処理について
基本的な使い方の(4)で新規追加用のダイアログが表示されます
「○○,△△」のように住所と番号をカンマ「,」で区切り指定してください。
（この場合の○○は住所、△△は番号です）
指定した内容が名簿リストの最終行に追加されます

■更新をする場合
(1)「作業用シート」のセル「A2」に対象の名前を入力
(2)「作業用シート」のセル「B2」「C2」に更新後の住所、電話を入力
(3)基本的な使い方の(2)と同様に「取得」を実行
(4)このとき、(1)の対象が見つからなければ新規追加処理にうつります。
(5)一致した名前が見つかれば(2)で入力した内容で「名簿シート」が更新されます。

■重複している場合
基本的な使い方で「A2」で指定した名前が重複している場合は重複削除の確認表示がでます。
「はい」をクリックで一番上の一つを残して「名簿シート」から対象の重複行が削除されます。
（注意！！！！！）
住所、番号の重複チェックはしておらず、名前が重複しているかどうかで判断しています。
名前が同じであれば、住所、番号が異なっていても削除されます。

■指定削除（おまけ機能）
(1)セル「A2」に対象の名前を入力します
(2)セル「B2」に「del」を入力します
(3)マクロ「取得」を実行すると指定した名前の行が名簿シートから削除されます

■設定変更
コード内の以下の場所を変更することである程度のフォーマットの変化に対応できます。
(1)「作業用シート」や「名簿シート」が以下の「"作業用シート"」、「"名簿"」の部分になります。
　　必要に応じて変更してください。

(2)"A2,B2,C2"が「作業用シート」において、入力・設定・取得する「名前、住所、電話」のセルになります。
　　変更する場合は「名前」「住所」「電話」セルの順番でカンマ「,」で区切って指定してください。

(3)"A,B,C"が「名簿シート」において、名前、住所、電話のセル記号になります。
　　変更する場合は「名前」「住所」「電話」の列記号の順番でカンマ「,」で区切って指定してください。

'▽設定---------------------------▽
Set tar(0) = Sheets("作業用シート")
col1 = Split("A2,B2,C2", ",")
Set tar(1) = Sheets("名簿")
col2 = Split("A,B,C", ",")
'△-------------------------------△

回答No.1

eden3616

様式の提示がなかったため、勝手に作りました。
こんな感じでどうでしょ？
コードだけで文字制限限界なので説明は次の回答にまたぎます。

■VBAコード

Option Explicit
Dim tar(1) As Worksheet
Dim col1, col2, dat

Sub 取得()
Dim rmax As Long

Dim hit As Long
Dim inp As String
Dim flag, del

'▽設定---------------------------▽
Set tar(0) = Sheets("作業用シート")
col1 = Split("A2,B2,C2", ",")
Set tar(1) = Sheets("名簿")
col2 = Split("A,B,C", ",")
'△-------------------------------△

With tar(1)
rmax = .Range(col2(0) & Rows.Count).End(xlUp).Row
hit = 検索(.Range(col2(0) & "1:" & col2(0) & rmax), tar(0).Range(col1(0)))
If hit < 0 Then
'重複した場合→削除確認→（削除処理）→終了
If MsgBox("""" & tar(0).Range(col1(0)) & """の重複行を削除しますか？", vbYesNo, "重複しています") = vbYes Then
MsgBox "削除数/重複数：" & 重複(.Range(col2(0) & "1:" & col2(0) & rmax), rmax, tar(0).Range(col1(0)), Abs(hit)), vbOKOnly, "削除しました"
End If
Exit Sub
End If
If hit = 0 Then
'見つからなかった場合→追加確認→（追加処理）→終了
If MsgBox("""" & tar(0).Range(col1(0)) & """を追加しますか？", vbYesNo, "名前が見つかりません") = vbYes Then
inp = InputBox("住所と電話をカンマ「，」で区切って入力してください", "登録します", "住所,電話")
If inp <> "" Then
dat = Split(inp, ",")
tar(1).Range(col2(0) & rmax + 1) = tar(0).Range(col1(0))
tar(1).Range(col2(1) & rmax + 1) = dat(0)
tar(1).Range(col2(2) & rmax + 1) = dat(1)
MsgBox "追加しました"
Else
GoSub cn1
End If
Else
GoSub cn1
End If
tar(0).Range(col1(1), col1(2)).ClearContents
Else
'見つかった場合→削除チェック
If Len(tar(0).Range(col1(1))) + Len(tar(0).Range(col1(1))) > 0 Then
'削除チェック
If tar(0).Range(col1(1)) = "del" Then
'削除確認→（削除処理）
del = MsgBox("""" & tar(1).Range(col2(0) & hit) & """を削除しますか？", vbYesNoCancel, "確認")
If del = vbYes Then
MsgBox """" & tar(1).Range(col2(0) & hit) & """を削除しました"
tar(1).Rows(hit).Delete
End If
If del = vbCancel Then GoTo cn2
Else
'更新確認→（更新処理）
flag = MsgBox("""" & tar(1).Range(col2(0) & hit) & """を更新しますか？", vbYesNoCancel, "住所または電話が空欄ではありません")
If flag = vbYes Then
tar(1).Range(col2(1) & hit) = tar(0).Range(col1(1))
tar(1).Range(col2(2) & hit) = tar(0).Range(col1(2))
MsgBox """" & tar(1).Range(col2(0) & hit) & """を更新しました"
End If
If flag = vbCancel Then GoTo cn2
End If
End If
'削除・更新以外で取得
If del <> vbYes And flag <> vbYes Then
tar(0).Range(col1(1)) = tar(1).Range(col2(1) & hit)
tar(0).Range(col1(2)) = tar(1).Range(col2(2) & hit)
Application.ScreenUpdating = False
tar(1).Activate
tar(1).Rows(hit).Select
tar(0).Activate
Application.ScreenUpdating = True
MsgBox "取得しました"
End If
End If
End With
Exit Sub

cn1:
MsgBox "キャンセルされました"
Return

cn2:
MsgBox "キャンセルされました"
End Sub

Function 重複(tar_r As Range, rmax As Long, word As String, hit As Long) As String
Dim i As Long
Dim cnt As Long
Dim nrow As Long

For i = tar_r.Count To 1 Step -1
If tar_r.Cells(i) = word Then
nrow = tar_r.Cells(i).Row
If nrow <> hit Then
重複 = 重複 & vbCrLf & tar_r.Cells(i) & " (" & nrow & "行目)"
tar(1).Rows(nrow).Delete
End If
cnt = cnt + 1
End If
Next i
重複 = cnt - 1 & "/" & cnt & 重複
End Function

Function 検索(tar As Range, word As Variant)
Dim i As Long
Dim hit As Integer
On Error GoTo era
For i = 1 To tar.Count
If tar.Cells(i) = word Then hit = hit + 1
Next i
If hit > 1 Then 検索 = -1 * tar.Find(word).Row: Exit Function
検索 = tar.Find(word).Row
Exit Function
era:
検索 = 0
End Function

お礼

いつもありがとうございます。

使っている様式が詳しく伝えられなくてすいませんでした。

作業用のシートを作成した後はプリントアウトします。名前と住所そして電話番号を入力しなければいけない書類なので、名前を検索してなるべく入力しなくても作成出来るようにしたいと考えてます。
名前を検索して登録されて無ければ、ついでに登録出来たら、次に作成する人は楽になると考えました。
教えていただいたコードを参考に試してみます。