質問の追加です


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回まで
  • 13歳以上
  • 登録:2011/06/27 14:31:59
  • 終了:2011/06/27 16:43:29

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/06/27 15:54:06

ポイント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ベストアンサー獲得回数11982011/06/27 14:56:58

ポイント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

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

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

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/06/27 15:54:06ここでベストアンサー

ポイント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ベストアンサー獲得回数11982011/06/27 15:58:02

ポイント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

  • id:inosisi4141
    takntさん
    訂正
    A列                       C列
    ffff@123.softbank.ne.jp.temp        softbank.ne.jp

    できなければ削除
  • id:taknt
    >できなければ削除

    どういうパターンでしょうか?
  • id:inosisi4141
    >できなければ削除


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

    答えのマクロでできました 
    ありがとうございます  
  • id:taknt
    No2の回答を修正しました。
  • id:inosisi4141
    takntさん
    ありがとうございました
    上手く行きました

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません