エクセルのマクロで検索

質問

教えてください。

エクセルにいろいろなセルに文字列が並んでいます。
フォームを作成し、テキストに文字列1、文字列2を指定します。
そこからある文字列1を検索し、もし見つかればその見つかった文字列1の右のセルに指定した文字列2を挿入したいのです。右のセルに文字列3がすでにある場合はその文字列3の下のセルに文字列2を挿入します。
もしみつからなければ、Aの一番下のセルに文字列2を挿入します。
といったプログラムをコーディングしたいのですが、マクロに関しては初心者です。VBは少しなら分かります。
できれば分かりやすく教えて頂けないでしょうか。
よろしくお願いします。

回答No.6

Musaffah · ベストアンサー

とりあえず、No.5で書いた内容に基づいてVBAマクロを作ってみました。これを参考にしてみてください。
（補足を待たずに早とちりで作ってしまいました。ごめんなさい。）

ただし、このNo.5で記述した内容では不備があります。
[会員組織図]ワークシートに
"A","A1","A12"
"B","B1"
"_","B2","B21"　※"_"は空欄
と登録している状態で、Aさんが紹介者となる新会員"A2"さんを登録する場合、B2さんの下のセルに登録するのでしょうか？
（私が何か勘違いしてたらごめんなさい。）

【内容】
フォームクラスをUserForm1とする。
下記VBAマクロを標準モジュールに追加する。
"会員登録"マクロを起動すると、会員登録フォームが表示される。
UserForm1クラスで、登録したいときにisEntryNewMenber()をコールする。
この関数の戻り値が
trueであれば登録成功。
falseであれば登録失敗。

===========================

Private ws As Worksheet

Public Sub 会員登録()
Dim frm As UserForm1

Set frm = New UserForm1
Load frm
frm.Show

End Sub

Public Function isEntryNewMenber(strNewMenber As String, strIntroductor As String) As Boolean
Dim rIntroCell As Range
Dim iRow, iCol As Integer

isEntryNewMenber = False
Set ws = Worksheets("会員組織図")
strNewMenber = Trim(strNewMenber)
strIntroductor = Trim(strIntroductor)

If Len(strIntroductor) <> 0 Then '紹介者あり？
Set rIntroCell = findMenber(strIntroductor) '紹介者検索
If Not rIntroCell Is Nothing Then '紹介者発見？
Call entryNewMenber1(rIntroCell, strNewMenber) '紹介者の隣に登録
isEntryNewMenber = True
Else '紹介者の名前なし
'エラーメッセージ表示
End If
Else '紹介者なし
Call entryNewMenber2(strNewMenber) '会員登録
isEntryNewMenber = True
End If

End Function

'紹介者の名前検索
Private Function findMenber(ByVal strName As String) As Range
Set findMenber = ws.Cells.Find(what:=strName) '氏名検索
End Function

'新会員登録（紹介者あり）
Private Sub entryNewMenber1(ByVal rIntroCell As Range, ByVal strName As String)
Dim iRow, iCol As Integer

iRow = rIntroCell.Row
iCol = rIntroCell.Column + 1

While Len(Trim(ws.Cells(iRow, iCol))) <> 0
iRow = iRow + 1
Wend

ws.Cells(iRow, iCol) = strName
End Sub

'新会員登録（紹介者なし）
Private Sub entryNewMenber2(strName As String)
Dim iRow, iCol As Integer
Dim rEntryCell As Range
Dim strR As String
Dim i As Integer

iRow = 0
Do
strR = "IV" & CStr(iRow + 1)
Set rEntryCell = Range(strR).End(xlToLeft)
iRow = iRow + 1
iCol = rEntryCell.Column
Loop Until (iCol = 1) And (Len(Trim(ws.Cells(iRow, iCol))) = 0)

ws.Cells(iRow, iCol) = strName
End Sub

補足

Aさんが紹介者となる新会員"A2"さんを登録する場合、A1さんの下に挿入したいと思っております。
"A","A1","A12"
"_","A2"
"B","B1"
"_","B2","B21"　※"_"は空欄

よろしくお願いします。