id:inosisi4141
ポイントあり100ptベストアンサーあり
コンピュータインターネット

質問の追加です


A列のデータの中に
@と参照ドメインの間または参照ドメインの後ろに別の文字または数字があれば削除して
削除したメールアドレスをB列に参照ドメインだけをC列に書き出すことができますか？
　　　A列　　　　　　　　　　　　　　　B列　　　　　　　　　　　　　　　C列
aaaa@123.docomo.ne.jp　　　aaaa@docomo.ne.jp　　　　docomo.ne.jp
bbbb@test.ezweb.ne.jp　　　bbbb@ezweb.ne.jp　　　　　ezweb.ne.jp
cccc@docomo.ne.jo.456　　　cccc@docomo.ne.jo　　　　docomo.ne.jp
dddd@ezweb.ne.jp.temp　　　dddd@ezweb.ne.jp　　　　　ezweb.ne.jp
別マクロでもかまいません以上よろしくお願いします。

回答の条件
  • 1人3回まで
  • 登録：
  • 終了：2011/06/27 16:43:29
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:taknt No.2

回答回数13539ベストアンサー獲得回数1198

ポイント33pt

3回だけしか回答できないので 2番目の回答を修正しました。

sheet2のシートに A列にドメイン、B列に識別を入れてもらえれば

処理できるようにしました。

答えを入れるところ sheet1に入れてください。

sheet2に 以下の分を貼り付け

A列
t.vodafone.ne.jp
c.vodafone.ne.jp
d.vodafone.ne.jp
h.vodafone.ne.jp
r.vodafone.ne.jp
k.vodafone.ne.jp
n.vodafone.ne.jp
s.vodafone.ne.jp
q.vodafone.ne.jp
softbank.ne.jp
disney.ne.jp
docomo.ne.jp
ezweb.ne.jp

B列
t.vodafone
c.vodafone
d.vodafone
h.vodafone
r.vodafone
k.vodafone
n.vodafone
s.vodafone
q.vodafone
softbank
disney
docomo
ezweb

A列　　　　　　　　　　　B列

t.vodafone.ne.jp t.vodafone

こういう感じにしてください。



Sub main()

b = Range("A1").End(xlDown).Row
If Range("A2") = "" Then b = 1

b1 = Sheets("Sheet2").Range("A1").End(xlDown).Row
If Sheets("Sheet2").Range("A2") = "" Then b1 = 1


For a = 1 To b
    
    c = Cells(a, "A")
    d = InStr(c, "@")
    e = Right(c, Len(c) - d)
    
    g = ""
    For a1 = 1 To b1
        f = InStr(e, Sheets("Sheet2").Cells(a1, "B"))
        If f > 0 Then
            g = Sheets("Sheet2").Cells(a1, "A")
            Exit For
        End If
    Next a1
    
    Cells(a, "C") = g
        
    h = Right(c, Len(e) - f + 1)
    i = Left(h, Len(g))
    i = Left(c, d) & i

    Cells(a, "B") = i
Next a


End Sub
id:inosisi4141

どうもありがとうございました

バッチリです

例えば

t.vodafone.ne.jp

c.vodafone.ne.jp

d.vodafone.ne.jp

h.vodafone.ne.jp

r.vodafone.ne.jp

k.vodafone.ne.jp

n.vodafone.ne.jp

s.vodafone.ne.jp

q.vodafone.ne.jp

softbank.ne.jp

disney.ne.jp

以上を追加する場合をおしえてください

よろしくお願いします

2011/06/27 16:09:59

その他の回答（2件）

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

ポイント34pt

残念ながら これは 無理です。

できません。

たとえば

cccc@docomo.ne.jo.456　　　cccc@docomo.ne.jo　　　　docomo.ne.jp

の場合

このメールアドレスが ドコモのものであるという認識が必要ですよね。

どのような条件で ドコモのメールアドレスであるのかという判断は したらいいのかが 不明です。

で docomo という文字列が 入っていたら ドコモにするのか

ezwebという文字が入ってたら auにするのか？などです。

cccc@docomo.ne.jo.456には @以降に docomo という文字が入ってるので

ドコモならば docomo.ne.jpを C列にセット。

B列は どうやったらいいのか不明。

cccc@docomo.ne.jo.456　→　cccc@docomo.ne.jo

cccc@temp.docomo.ne.jo.456　→　?


また メールアドレスは ドコモとauだけのようですが、

ほかの場合は 対応しないのでしょうか？

id:inosisi4141

ありがとうございます

参照にあるドメインの後ろにある文字を切り取りそのドメインをC列にかきだす

参照にある文字がセットで含まれる行を検索しそのドメインをC列にかきだす

参照A列

docomo.ne.jp

ezweb.ne.jp

softbank.ne.jp

答え

A列　　　　　　　　　　　　　　　B列　　　　　　　　　　　　　　　C列

cccc@docomo.ne.jo.456　　　cccc@docomo.ne.jo　　　　 docomo.ne.jp

dddd@ezweb.ne.jp.temp　　　dddd@ezweb.ne.jp　　　　　ezweb.ne.jp

eeee@123.softbank.ne.jp　　　　　　　　　　　　　　　　softbank.ne.jp

ffff@123.softbank.ne.jp.temp softbank.ne.jp

以上２点であればマクロでできますか

2011/06/27 15:52:37
id:taknt No.2

回答回数13539ベストアンサー獲得回数1198ここでベストアンサー

ポイント33pt

3回だけしか回答できないので 2番目の回答を修正しました。

sheet2のシートに A列にドメイン、B列に識別を入れてもらえれば

処理できるようにしました。

答えを入れるところ sheet1に入れてください。

sheet2に 以下の分を貼り付け

A列
t.vodafone.ne.jp
c.vodafone.ne.jp
d.vodafone.ne.jp
h.vodafone.ne.jp
r.vodafone.ne.jp
k.vodafone.ne.jp
n.vodafone.ne.jp
s.vodafone.ne.jp
q.vodafone.ne.jp
softbank.ne.jp
disney.ne.jp
docomo.ne.jp
ezweb.ne.jp

B列
t.vodafone
c.vodafone
d.vodafone
h.vodafone
r.vodafone
k.vodafone
n.vodafone
s.vodafone
q.vodafone
softbank
disney
docomo
ezweb

A列　　　　　　　　　　　B列

t.vodafone.ne.jp t.vodafone

こういう感じにしてください。



Sub main()

b = Range("A1").End(xlDown).Row
If Range("A2") = "" Then b = 1

b1 = Sheets("Sheet2").Range("A1").End(xlDown).Row
If Sheets("Sheet2").Range("A2") = "" Then b1 = 1


For a = 1 To b
    
    c = Cells(a, "A")
    d = InStr(c, "@")
    e = Right(c, Len(c) - d)
    
    g = ""
    For a1 = 1 To b1
        f = InStr(e, Sheets("Sheet2").Cells(a1, "B"))
        If f > 0 Then
            g = Sheets("Sheet2").Cells(a1, "A")
            Exit For
        End If
    Next a1
    
    Cells(a, "C") = g
        
    h = Right(c, Len(e) - f + 1)
    i = Left(h, Len(g))
    i = Left(c, d) & i

    Cells(a, "B") = i
Next a


End Sub
id:inosisi4141

どうもありがとうございました

バッチリです

例えば

t.vodafone.ne.jp

c.vodafone.ne.jp

d.vodafone.ne.jp

h.vodafone.ne.jp

r.vodafone.ne.jp

k.vodafone.ne.jp

n.vodafone.ne.jp

s.vodafone.ne.jp

q.vodafone.ne.jp

softbank.ne.jp

disney.ne.jp

以上を追加する場合をおしえてください

よろしくお願いします

2011/06/27 16:09:59
id:taknt No.3

回答回数13539ベストアンサー獲得回数1198

ポイント33pt

softbankを追加してみました。

参照A列は プログラム内に持っています。


Sub main()

b = Range("A1").End(xlDown).Row
If Range("A2") = "" Then b = 1

For a = 1 To b
    
    c = Cells(a, "A")
    d = InStr(c, "@")
    e = Right(c, Len(c) - d)
    
    f = InStr(e, "docomo")
    g = "docomo.ne.jp"
    If f = 0 Then
        f = InStr(e, "ezweb")
        g = "ezweb.ne.jp"
        
        If f = 0 Then
            f = InStr(e, "softbank")
            g = "softbank.ne.jp"
        End If
    End If
    
    Cells(a, "C") = g
        
    h = Right(c, Len(e) - f + 1)
    i = Left(h, Len(g))
    i = Left(c, d) & i

    Cells(a, "B") = i
Next a


End Sub

コメント（5件)

  • id:inosisi4141
    inosisi 2011/06/27 15:55:50
    takntさん
    訂正
    A列　　　　　　　　　　　　　　　　　　　　　　　C列
    ffff@123.softbank.ne.jp.temp　　　　　　　 softbank.ne.jp

    できなければ削除
  • id:taknt
    きゃづみぃ 2011/06/27 15:59:29
    ＞できなければ削除

    どういうパターンでしょうか？
  • id:inosisi4141
    inosisi 2011/06/27 16:15:48
    ＞できなければ削除


    前後にドメイン以外の別もじがある場合のことです
    ffff@123.softbank.ne.jp.temp　　　　

    答えのマクロでできました　
    ありがとうございます　　
  • id:taknt
    きゃづみぃ 2011/06/27 16:25:09
    No2の回答を修正しました。
  • id:inosisi4141
    inosisi 2011/06/27 16:45:44
    takntさん
    ありがとうございました
    上手く行きました

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ