EXCEL VBA マクロがうまく動作しません

いつもお世話になっております。
EXCELのマクロについて教えてください。
シートに
男
・男・
女・
・・男
・男・・
・女
上記のように１つのセルに「・男」「女」
など文字だけでなく「・」がバラバラに入った
データが列方向に４００件あります
次の列に、「男」「女」だけの文字だけを抜き取りたいので、下のようなマクロを組みました。

Sub 性別取り出し()
Range("a2").Select

Do Until retu = 2
retu = ActiveCell.Column
Cells.Find(What:="男", After:=ActiveCell, 　　　　LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns,
　　SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False,
　　SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate

ActiveCell.Offset(0, 2).Activate
ActiveCell.Value = "男"
ActiveCell.End(xlToLeft).Activate
Loop


MsgBox counter & "回ループしました"
End Sub

　　A列　　B列
男　　　｜男
・男・　｜男
女・　　｜
・・男　｜男　
・男・・｜男
・女　　｜

というような結果を期待したのですが

実際は
　　A列　　B列
男　　　｜男　　｜　男
・男・　｜　　　｜　　
女・　　｜　　　｜
・・男　｜男　　｜　男　
・男・・｜　　　｜
・女　　｜　　　｜

のように、B列の結果が飛び飛びになったり
C列以降に男の文字が入ったり
永遠にループを続けたりします。

いろいろ試しましたが、うまくいきません
どうしたら良いか教えてください。
よろしくお願いします。

ちなみにデータの「・」はALT＋ENTERの改行マークか何らかのスペースの跡らしく、検索や置換では引っかかりません。

No.6 ベストアンサー 回答者： BLUEPIXY 回答日時： 2005/10/26 14:21

>問題は「・・」です。

まずは、そのゴミがなにであるか調べましょう。
列を挿入して、作業列を作り
Ａ，Ｂ，Ｃ
データ(A1),=MID($A$1,ROW(),1),=CODE(MID($A$1,ROW(),1))
のようにして、Ｂ，Ｃを下にコピーすると
それぞれの文字がＢに、その文字のコードがＣに表示されます。
例えば、ALT+ENTERで改行されている場合
コードとして 10 が表示されます。(文字としては表示されません)
件のデータのコードがわかれば
=SUBSTITUTE(A1,CHAR(10),"")
のようにして、件のデータ（この例の場合は、コード１０）を取り除くことができます。
文字の区切りのマークとして残しておきたい場合は
=SUBSTITUTE(A1,CHAR(10),"<BR>")
などとすればいいでしょう。

この回答へのお礼

ありがとうございました。コードとして13が表示されましたので、SUBSTITUTE関数を使って取り除くことができました。
助かりました。本当にありがとうございました。

お礼日時：2005/10/26 16:44

No.5 回答者： Wendy02 回答日時： 2005/10/26 11:29

こんにちは。

Findメソッドは、決まったアルゴリズムを使います。それ以外の方法ではうまくいかないことが多いです。一応、"女"の文字は、男の隣のセルに出すようにしました。
いっしょのセルなら、サブルーチンの中の

　.Offset(, i + 1).Value
は、
　.Offset(, 1).Value
にしてください。


'-------------------------------------------

Sub PickUpAtCells()
　 Dim c As Range
　 Dim myFadd As String
　 Dim rng As Range
　 Dim i As Integer
　 Dim Genders(1) As String
　 Genders(0) = "男"
　 Genders(1) = "女"
　 Set rng = ActiveSheet.Columns(1)
　 Application.ScreenUpdating = False
　 For i = 0 To 1
　　　Set c = rng.Find( _
　　　　What:="*" & Genders(i) & "*", _
　　　　LookIn:=xlValues, _
　　　　LookAt:=xlPart, _
　　　　SearchOrder:=xlByColumns, _
　　　　SearchDirection:=xlNext)
　　　If Not c Is Nothing Then
　　　　 myFadd = c.Address
　　　　 Do
　　　　　　s_PickupCells c, Genders(i), i 'サブルーチンへ
　　　　　　Set c = rng.FindNext(c)
　　　　 Loop Until c Is Nothing Or c.Address = myFadd
　　　End If
　 Next i
　 Application.ScreenUpdating = True
End Sub

Sub s_PickupCells(myRng As Range, SearchWord As String, i As Integer)
'サブルーチン
Dim number As Integer
　number = InStr(myRng, SearchWord)
　If number > 0 Then
　 myRng.Offset(, i + 1).Value = Mid$(myRng.Value, number, 1)
　End If
End Sub

'-------------------------------------------

No.4 回答者： shinchan_k 回答日時： 2005/10/26 11:29

例えば、B1に=MID(A1,IF(ISERROR(FIND("男",A1)),0,FIND("男",A1))+IF(ISERROR(FIND("女",A1)),0,FIND("女",A1)),1)

としてはいかがでしょう。ただし、1つのセルに男or女が2文字以上あるとだめですが・・・
男だけ表示するのなら
=MID(A1,IF(ISERROR(FIND("男",A1)),0,FIND("男",A1)),1)
でいけると思います。

No.3 回答者： kenken_ken 回答日時： 2005/10/26 11:27

もっと簡単にできました。

=IF(ISNA(MATCH("*男*",A1,0)),"女","男")

No.2 回答者： BLUEPIXY 回答日時： 2005/10/26 11:25

原因は、

>Cells.Find
で、検索する範囲をＡ列に限定していないのが１つの原因だと思います。
マクロによらないでも、単にＢ列に
=IF(COUNTIF(A1,"*男*"),"男",IF(COUNTIF(A1,"*女*"),"女",""))
とするだけでいいと思います。

この回答への補足

ありがとうございました。うまく動作しました。
実はこの後にもデータを抜き出さなくてはいけない作業が山済みになっています。
それは、B2セルには
　　　「指導内容は○○/△△・・・・対象は○○」

　　　　B3セルには
　　　「指導内容は△△/◇◇/○○・・対象は△△」
というような情報から
「指導内容は○○/△△」のみや
「対象は△△」を取り出すのですが
MIDやFIND関数で取り出すことはできると考えています。
問題は「・・」です。
先ほども記述しましたが、「・・」は文字でなく
改行かスペースの跡らしく検索や置換ができません。
セルによってその数もばらばらなので

「指導内容は○○/△△・・・・」
「指導内容は○○/△△・・」
と「・・」が残ってしまいます。
どうすればよいのでしょうか。
ぜひよろしくお願いします

補足日時：2005/10/26 13:26

No.1 回答者： kenken_ken 回答日時： 2005/10/26 11:13

Cell関数ではダメですか？

Cell B1に以下の関数を入力してください。
=IF(ISNA(VLOOKUP("*男*",A1,1,FALSE)),IF(ISNA(VLOOKUP("*女*",A1,1,FALSE)),"？","女"),"男")

で、Cell B1を選択し、A列の最後のデータの行まで、ずずーっとドラッグ（要するにコピーですね）。
すると、B列に「男」「女」、どちらもなければ「？」が表示されると思います。

註：「ツール」-> 「アドイン」メニューで、「分析ツール」を選択しておいてください。