VBA 地名を抽出し、セルごとに分ける

質問

Gセルに名前、地名が並んでいます。
地名を超出し、分けるようにAセルからFセルまで並べます。
イメージ画像のようにしたいです。
VBAはどのようにしたら良いでしょうか？
宜しくお願いします。

回答No.2

kkkkkm · ベストアンサー

たとえば地名の範囲はA1:F1として「(」は半角だとした場合です。
また、地名の範囲がA列から始まらない場合mOffsetの0を右に移動した数にしてください
A列からではなくB列から始まった場合B1:G1と変更した場合
1列右に寄ったので
mOffset = 1

Sub Test()
Dim i As Long, mCol As Variant, mOffset As Variant
Dim FStr As String, tmp As String

mOffset = 0
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
If Cells(i, "G").Value <> "" Then
tmp = Split(Cells(i, "G"), "(")(1)
FStr = Left(tmp, Len(tmp) - 1)
mCol = Application.Match(FStr, Range("A1:F1"), 0)
If IsError(mCol) Then
MsgBox "地名が存在しません。　" & Cells(i, "G").Value, vbInformation
Else
Cells(Cells(Rows.Count, mCol + mOffset).End(xlUp).Row + 1, mCol + mOffset).Value = Cells(i, "G").Value
End If
End If
Next
End Sub

お礼

コメントありがとうございます。
バッチリです。ありがとうございました。

回答No.3

imogasi

第１行に、地名はすでにセットされているとする。（A-F列第１行）
ーー
標準モジュールに
Sub test01()
lr = Range("G100000").End(xlUp).Row
MsgBox lr
For i = 2 To lr
x = Cells(i, "G")
y = Split(x, "（") '（は、全角であるとする
Z = Replace(y(1), "）", "")
'MsgBox Z
c = Range("a1:F1").Find(what:=Z).Column
'MsgBox c
r = Cells(100000, c).End(xlUp).Row
Cells(r + 1, c) = y(0)
Next i
End Sub
実行
ーー
質問のデータで
結果（列位置は崩れていると思うが、実際のテスト結果を見てください）
仙台　宮城 福島 　千葉　 茨城 　東京　 神奈川
山田太郎　 高橋花子　 鈴木太郎 高橋太郎 　楠太郎
斎藤太郎 橘花子
　 佐藤花子
Msgbox行は、データが少数のテストの場合には、生かしてください。
FindはMatch関数でもできそう。エクセル関数好きの者にはよいかも。
c = Application.WorksheetFunction.Match(Z, Range("A1:F1"), 0)
本題はEnd(xlUp).の応用だけ、といった感じか？
あと、カッコ内の文字をどう抜き出すか。
初心者なら、上記のようにやらずとも、１文字ずつ「（」や「）」かどうか（IF文で）見て行けば仕舞だろう。

お礼

コメントありがとうございます。
動作は良かったですが、（地位名）が削除してしまうことは残念でした。

回答No.1

linerjp

ソースコードにしないでプロセスだけ明示しますので、ソース自体はご自身で考えてください。

（1）G2セルから読み出して仮の変数Aへ。
（2）変数における"("の位置を確認させる。
（3）変数における")"の位置を確認させる。
（4）(2)の位置から(3)の位置までの文字を仮の変数Aから抜き出して別の変数Bに納める。
（5）A1セルからF1セルまで順番に、Bと合致するかどうか調べる。
（6）合致したら当該列の空行を探し、見つかった座標に仮の変数Aを代入する。
（7）G3セルを読み出しするようターゲットを変更する→（1）1へ戻る。空白に当たったら終了する。