エクセルで住所録を分類する方法は

質問

いつもお世話になっています。（エクセルは２００２です）

　　Ａ　　　　　Ｂ　　　　　　　Ｃ　　　Ｄ　　　Ｅ
１　郵便番号　　住所　　　　　　氏名　　地区　　備考
２　１００　　　Ａ県Ｂ市Ｃ町　　Ｃ氏　　Ｅ　　　Ｇ
３　１００　　　Ａ県Ｂ市Ｄ町　　Ｃ氏　　Ｅ　　　Ｇ
４　２００　　　Ｂ県　　　　　　Ｄ氏　　Ｆ　　　Ｈ

上記のような表（シート１）があります。
シート２にＡ県、シート３にＡ県以外を郵便番号・住所・氏名・地区・備考を分けて、シート２の表をシート４にＢ市、シート５にＢ市以外に郵便番号・住所・氏名・地区・備考を分けて、シート４の表をシート６にＣ町、シート７にＣ町以外に郵便番号・住所・氏名・地区・備考を分ける方法を教えてください。

うまく説明できませんがよろしくお願いします

回答No.2

nishi6 · ベストアンサー

参考にコードを書いてみました。
ツール→マクロ→Visual Basic Editor でVBE画面に移り、挿入→標準モジュール で標準モジュールを挿入します。 出てきたコードウインドウに下記マクロをコピーして貼り付けます。

最初の3行のs県名、s市名、s町名の右辺に実際の県・市・町をセットします。
シートは最低７枚作成しておいて下さい。コードが長くなるので、シート数のチェック等はしていません。

ご参考に。

ここから
↓
Sub JyusyoFuriwake()
　　Const s県名 = "Ａ県"　　　　'*** 実際の県名をセットする ***
　　Const s市名 = "Ｂ市"　　　　'*** 実際の市名をセットする ***
　　Const s町名 = "Ｃ町"　　　　'*** 実際の町名をセットする ***

　　Dim 県名 As String, 市名 As String, 町名 As String
　　'各シートに分離する条件の住所を定義する
　　県名 = s県名 'Sheet2
　　市名 = 県名 & s市名 'Sheet4
　　町名 = 市名 & s町名 'Sheet6

　　Const wsNum = 7 'ワークシートの数
　　Const Koumoku = 5 '転記する項目数(E列=5)
　　Dim ws(7) As Worksheet 'ワークシート
　　Dim rw() As Long 'シート毎の書き込み可否
　　Dim rwT(7) As Long 'シート毎の書き込む行カウンタ
　　Dim w As Integer 'ワークシートカウンタ
　　Dim r As Long, c As Integer '行カウンタ、列カウンタ

　　For w = 1 To wsNum
　　　　Set ws(w) = Worksheets("Sheet" & w) 'ワークシートを定義する
　　　　If w >= 2 Then 'Sheet2～Sheet7の処理
　　　　　　ws(w).Cells.ClearContents '一応クリア
　　　　　　For c = 1 To Koumoku
　　　　　　　　ws(w).Cells(1, c) = ws(1).Cells(1, c) '表題をセットする
　　　　　　Next
　　　　End If
　　Next
　　ws(1).Activate

　　Dim 住所 As String '読み込んだ住所
　　Dim wsNo As Integer '書き込むシート番号
　　For r = 2 To Range("A65536").End(xlUp).Row
　　　　住所 = ws(1).Cells(r, 2)
　　　　ReDim rw(7) As Long 'シート毎の行カウンタ
　　　　If Left(住所, Len(県名)) = 県名 Then
　　　　　　rw(2) = r: rwT(2) = rwT(2) + 1 'シート2
　　　　　　If Left(住所, Len(市名)) = 市名 Then
　　　　　　　　rw(4) = r: rwT(4) = rwT(4) + 1 'シート4
　　　　　　　　If Left(住所, Len(町名)) = 町名 Then
　　　　　　　　　　rw(6) = r: rwT(6) = rwT(6) + 1 'シート6
　　　　　　　　Else
　　　　　　　　　　rw(7) = r: rwT(7) = rwT(7) + 1 'シート7
　　　　　　　　End If
　　　　　　Else
　　　　　　　　rw(5) = r: rwT(5) = rwT(5) + 1 'シート5
　　　　　　End If
　　　　Else
　　　　　　rw(3) = r: rwT(3) = rwT(3) + 1 'シート3
　　　　End If

　　　　'シートに書き込む
　　　　For w = 2 To wsNum
　　　　　　If rw(w) > 0 Then
　　　　　　　　For c = 1 To Koumoku
　　　　　　　　　　ws(w).Cells(rwT(w) + 1, c) = ws(1).Cells(r, c)
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　Next
　　MsgBox "処理が終わりました。"
End Sub

お礼

思っていたように出来ました。
いつも、ありがとうございます。
これからもよろしくお願いします

回答No.1

comv

こんばんは！

ご希望の処理方法が
数式でなのかＶＢＡでか直接操作でなのか不明ですが

直接作業での方法を１例

・シート２に以下のように記載

　　　Ａ
　１　住所
　２　Ａ県*
　３
　４　

・シート２　Ａ４を選択
・データ　フィルタ　フィルタオプションの設定
　抽出先　　　指定した範囲　をチェック
　リスト範囲　シート１の項目を含む全体範囲を選択
　検索条件　　Ａ１：Ａ２を選択
　抽出範囲　　Ａ４を選択
　ＯＫ

以下同様の作業
シート３　Ａ２　の条件記載　<>Ａ県*
シート４　Ａ２　の条件記載　*Ｂ市*
シート５　Ａ２　の条件記載　<>*Ｂ市*
シート６　Ａ２　の条件記載　*Ｃ町*
シート７　Ａ２　の条件記載　<>*Ｃ町*

シート４以降もシート１を対象として抽出する場合

シート４

　　　Ａ　　　Ｂ
　１　住所　　住所
　２　Ａ県*　*Ｂ市*
　３
　４　

検索条件範囲　Ａ１：Ｂ２

とすればＯＫです

同様に
　シート５では　Ａ県*　 <>*Ｂ市*
　シート６では条件が３つになり

　　　Ａ　　　　Ｂ　　　　Ｃ
　１　住所　　　住所　　　住所
　２　Ａ県*　　*Ｂ市*　　*Ｃ町*

　シート７では　Ａ県*　　*Ｂ市*　　<>*Ｃ町*

となります。

お礼

ありがとうございました。

補足

住所録の件数が増えていくので、もし出来るのであれば、自動処理でお願いします。

間違っていたらごめんなさい、自動処理でしたらVBAですよね。関数でも出来るのかな？

VBAは、始めたばかりなので、VBAの記述もお願いします。