EXCELマクロでA列のメアドをチェックする方法

質問

今月からマクロの勉強を始めたばかりの素人です
仮にA1:A100にメアドが入力されたcsvデータがあるとします。(B1:F100にも名前やURL等のデータあり)
ウェブ上で閲覧者が入力したメルマガ登録者リストのようなものをイメージして下さい、事情により閲覧者入力時の書式チェックはできないため、メアドでないもの、全角で入っているもの、メアドにはあり得ない記号等が混じっているもの、なども混在している可能性があります。
マクロで簡易に検査し、明らかにメアドでないものがあればとりあえず一行目に移動します。
自分で考えたマクロの検査部分は以下です。

For i = 1 To 100
Cells(i, "A").Select
myCell = ActiveCell
myCell = Trim(myCell) '前後に余分なスペースがあれば削除
m = InStr(myCell, "＠")
n = InStr(myCell, "@")
o = InStr(myCell, ".")
If m <> 0 Then '全角＠があった場合、全角で入力されている可能性がある・戻り値が"0"以外になる
Rows(i).Cut '先頭列へ移動
Rows(1).Insert Shift:=xlDown
ElseIf n = 0 Then '半角@がなかった場合・メアドではない
Rows(i).Cut
Rows(1).Insert Shift:=xlDown
ElseIf o = 0 Then '半角"."が一つもない・メアドではない
Rows(i).Cut
Rows(1).Insert Shift:=xlDown
End If
Next i
全てのあり得るドメインをチェックしていくほどの精度は不要ですが、簡単に出来る検査があれば追加したいです。正規表現を使った文字列検査のような機能があればよいのですが、マクロではできないのでしょうか。
また、String変数中に全角文字が存在しているかどうかが一発でわかるような関数はないでしょうか。
上記のものよりスマートな（？）構文・高速な検査方法や、他の検査方法などもありましたら、イロイロ教えてください。よろしくお願いしますm(__)m

回答No.5

KenKen_SP · ベストアンサー

#3、#4 です。

＞ String変数中に全角文字が存在しているかどうかが一発でわかるような関数
＞ はないでしょうか。

#3 の正規表現でも全角文字もはじきますが、汎用的に使える関数を書いてみま
した。

【使い方】

Debug.Print EXIST_MULTIBYTECHAR("あいうabc")

結果：--＞　True

Debug.Print EXIST_MULTIBYTECHAR("abc")

結果：--＞　False

'// 引数の文字列中に全角文字が含まれるかチェック
Function EXIST_MULTIBYTECHAR(ByVal strTARGET As String) As Boolean

　　Dim lngCNT1 As Long, lngCNT2 As Long

　　'Excel 2000 以降 Unicode が採用されている
　　'Unicode は半角英数も2バイトなので単純比較できない

　　lngCNT1 = Len(strTARGET)
　　lngCNT2 = LenB(StrConv(strTARGET, vbFromUnicode))
　　EXIST_MULTIBYTECHAR = (lngCNT1 <> lngCNT2)

End Function

お礼

いろいろなテクを教えてくださりましてありがとうございます。初心者のわたしにはよく理解できない部分が多いですが、近くきっと役に立つと思います。

回答No.6

Wendy02

こんにちは。

KenKenSPさんが、あまり難しいのを出されてしまったので、こちらはちょっと出しにくいのですが。（^^;　

＞If m <> 0 Then '全角＠があった場合、全角で入力されている可能性がある・戻り値が"0"以外になる

ということは、ErrorLevel で関数の値を返すわけですね。
そのエラーレベルを、あまり欲張って数多く出しても処理速度を遅くするだけですから、一応、3つまでにしました。

Sub TestChecker()
Dim c As Range
For Each c In Range("B1:F100")
　If Not IsEmpty(c.Value) And VarType(c.Value) = vbString Then
　　Select Case MailAddChecker(c)
　　Case 1
　　　c.Interior.ColorIndex = 3　'アドレスではない場合赤
　　Case 2
　　　c.Interior.ColorIndex = 6　'全角混入は黄色
　　End Select
　End If
Next c
End Sub

Function MailAddChecker(ByVal strMailAddress As Variant) As Variant
'エラーレベル 0 =正常, 1=メールアドレスではない, 2 = 全角が混じっている
Dim ret As Integer
If VarType(strMailAddress) <> vbString Then _
　 MailAddChecker = CVErr(xlErrValue): Exit Function
If LenB(StrConv(strMailAddress, vbFromUnicode)) <> Len(strMailAddress) Then _
　 MailAddChecker = 2: Exit Function
With CreateObject("VBScript.RegExp")
　.Global = False
　.IgnoreCase = True
　.Pattern = "^[\w\-\.]+@[^\.]+\.[a-z]{2,}"
　 ret = CInt(.Test(strMailAddress)) + 1
End With
　MailAddChecker = ret
End Function

お礼

ご教授ありがとうございます。
メアドの有効性を正確にチェックしてくれる事も必要ですが、処理の軽いコードにも興味がありました。
ぜひ参考にさせていただきます。
＞.Pattern = "^[\w\-\.]+@[^\.]+\.[a-z]{2,}"
現段階の私にはなんとなくしかわかりませんが、正規表現を使った検査ですよね。こんな事もできるんですね！もう少し勉強して活用させていただきます。

回答No.4

KenKen_SP

#3 です。補足します。

例えば今回の例ですと、A列にメールアドレスが列挙されているなら
下記のようなコードでどうでしょう？

#3 のメールアドレスチェック関数もあわせて標準モジュール内にお
いて下さい。

先頭に1行挿入し、そこに関数の戻り値を書き込んでいます。

Sub SampleCode()

　　'関数の結果記入用の列挿入
　　Columns(1).Insert
　　'列挿入でデータは A列 から B列 になる
　　'1行目から最終行までループ処理で、チェック関数の結果を記載
　　For i = 1 To ActiveSheet.Range("B1").End(xlDown).Row
　　　　Cells(i, "A").Value = _
　　　　CHECK_MIALADDRESS(Cells(i, "B").Value)
　　Next i

End Sub

回答No.3

KenKen_SP

こんにちは。KenKen_SP です。

メールアドレスのチェックなら正規表現を使った関数を作れば良いと思います。
コード中のマッチングパターンを変更すれば、特定ドメインだけマッチする、、
といったチェックも可能です。

それをループ処理の中で使えば良いかと思います。

注意）下記の関数に書いたマッチングパターンはあくまで

「メールアドレスの書式として正しいか？」

の判定であって、実在するアドレスかどうかまではチェックしてません。

'// メールアドレス チェック関数
Function CHECK_MIALADDRESS(ByVal strMAILADDRESS As String) As Boolean

　　'動作環境：IE5.0以上がインストールされていること
　　'参照設定する場合は Microosft VBScript Regular Expressions x.x

　　Dim RegEx　　　As Object '参照設定の場合は RegExp で宣言
　　Dim strPATTERN As String

　　'メールアドレス正規表現マッチングパターン(例）
　　strPATTERN = "^([\w]+)([\w\.-]+)@([\w_\-]+)\.([\w_\.\-]*)[a-z][a-z]$"

　　'参照設定するなら Set RegEx = New RegExp
　　Set RegEx = CreateObject("VBScript.RegExp")
　　With RegEx
　　　　.Pattern = strPATTERN
　　　　.IgnoreCase = False
　　　　.Global = True
　　End With
　　If RegEx.Test(strMAILADDRESS) Then
　　　　CHECK_MIALADDRESS = True
　　End If
　　Set RegEx = Nothing

End Function

【使い方】

関数の戻り値はメールアドレスの書式として正しければ True を、不正なら
False を返します。次のように使います。

IF CHECK_MIALADDRESS(変数) = False Then
　　MsgBox "不正なアドレス", vbCritical
End If

回答No.2

e10go

こんばんわ。

メールアドレスの付け方には、規則があります。
例えば、使える文字は全て半角で、アルファベットの小文字(a～z)と数字(0～9)とハイフン(-）、アンダーバー(_）、ピリオド(.）、アットマーク(@)のみです。
また、先頭の文字はアルファベット(a～z)のみ、アットマーク(@)は1文字、アットマーク(@)とピリオド(.）は連続しない、等です。

メールアドレスに間違いがあるかは、メールアドレスの文字を1文字毎に上の条件を満たしているかを調べれば良い訳です。
その、マクロを作ってみました。
なお、下の例では、A1セル～A100セルまでメールアドレスがあるものとして作っています。
途中のセルに空白があると、その行を上にあげてしまいます。
また、エラーのメールアドレスのセルに色を付けています。

'－－－－－－－－マクロコード－－－－－－－－始まり
Option Explicit

Sub Mail_Address_Check()
　　Dim iHyphen As Integer 'ハイフン("-")のコード番号
　　Dim iUnderbar As Integer 'アンダーバー("_")のコード番号
　　Dim iPeriod As Integer 'ピリオド(".")のコード番号
　　Dim iAttomark As Integer 'アットマーク("@")のコード番号
　　Dim i0 As Integer '"0"のコード番号
　　Dim i9 As Integer '"9"のコード番号
　　Dim ia As Integer '"a"のコード番号
　　Dim iz As Integer '"z"のコード番号
　　Dim iAttomarkPosition As Integer
　　Dim iPeriodPosition As Integer
　　Dim iAttomarkCount As Integer
　　Dim istrCount As Integer 'メールアドレスの文字数
　　Dim i1 As Integer
　　Dim i2 As Integer
　　Dim istr As Integer
　　Dim iFlag As Integer
　　iHyphen = Asc("-") 'ハイフン("-")のコード番号
　　iUnderbar = Asc("_") 'アンダーバー("_")のコード番号
　　iPeriod = Asc(".") 'ピリオド(".")のコード番号
　　iAttomark = Asc("@") 'アットマーク("@")のコード番号
　　i0 = Asc("0") '"0"のコード番号
　　i9 = Asc("9") '"9"のコード番号
　　ia = Asc("a") '"a"のコード番号
　　iz = Asc("z") '"z"のコード番号
　　For i1 = 1 To 100
　　　　Cells(i1, 1) = Application.Substitute(Cells(i1, 1), " ", "")
'メールアドレス内のスペース(" ")を取り除く
　　　　istrCount = Len(Cells(i1, 1)) 'メールアドレスの文字数
　　　　If istrCount = 0 Then 'メールアドレスの文字数が0の場合、
　　　　　　Mail_Address_Move (i1) '先頭へ移動
　　　　Else 'メールアドレスの文字数が1以上の場合、メールアドレスの文字をチェック
　　　　　　iAttomarkPosition = 0
　　　　　　iPeriodPosition = 0
　　　　　　iAttomarkCount = 0
　　　　　　istr = Asc(Left(Cells(i1, 1), 1))
　　　　　　iFlag = 0
　　　　　　If istr >= ia And istr <= iz Then iFlag = 1
'先頭に"a～z"の文字を使用していたら、OK
　　　　　　If iFlag = 0 Then '先頭の文字チェックでOKにならない場合、
　　　　　　　　Mail_Address_Move (i1) '先頭へ移動
　　　　　　Else '先頭と最後の文字チェックでOKの場合、最後の文字をチェック
　　　　　　　　istr = Asc(Right(Cells(i1, 1), 1))
　　　　　　　　If istr >= ia And istr <= iz Then iFlag = 1
'最後に"a～z"の文字を使用していたら、OK
　　　　　　　　If istr >= i0 And istr <= i9 Then iFlag = 1
'最後に"0～9"の文字を使用していたら、OK
　　　　　　　　If istr = iHyphen Or istr = iUnderbar _
　　　　　　　　　　Or istr = iPeriod Or istr = iAttomark Then iFlag = 1
'最後に"-_."の文字を使用していたら、OK
　　　　　　　　If iFlag = 0 Then '最後の文字チェックでOKにならない場合、
　　　　　　　　　　Mail_Address_Move (i1) '先頭へ移動
　　　　　　　　Else '先頭と最後の文字チェックでOKの場合、中の文字をチェック
　　　　　　　　　　For i2 = 2 To istrCount - 1
　　　　　　　　　　　　iFlag = 0
　　　　　　　　　　　　istr = Asc(Mid(Cells(i1, 1), i2, 1))
　　　　　　　　　　　　If istr >= ia And istr <= iz Then iFlag = 1
'"a～z"の文字を使用していたら、OK
　　　　　　　　　　　　If istr >= i0 And istr <= i9 Then iFlag = 1
'"0～9"の文字を使用していたら、OK
　　　　　　　　　　　　If istr = iHyphen Or istr = iUnderbar _
　　　　　　　　　　　　　　Or istr = iPeriod Or istr = iAttomark Then iFlag = 1
'"-_.@"の文字を使用していたら、OK
　　　　　　　　　　　　If istr = iAttomark Then
　　　　　　　　　　　　　　iAttomarkPosition = i2 'アットマーク("@")の位置を記憶
　　　　　　　　　　　　　　iAttomarkCount = iAttomarkCount + 1
　　　　　　　　　　　　ElseIf istr = iPeriod Then
　　　　　　　　　　　　　　iPeriodPosition = i2 'ピリオド(".")の位置を記憶
　　　　　　　　　　　　End If
　　　　　　　　　　　　If iAttomarkCount > 1 Then iFlag = 0
'アットマーク("@")を2個以上使用していたらNG
　　　　　　　　　　　　If iAttomarkPosition = iPeriodPosition - 1 Then iFlag = 0
'アットマーク("@")の次にピリオド(".")があればNG
　　　　　　　　　　　　If iFlag = 0 Then '中の文字チェックでNGの場合、
　　　　　　　　　　　　　　Mail_Address_Move (i1) '先頭へ移動
　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　End If
　　　　　　　　　　Next i2
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next i1
End Sub
Sub Mail_Address_Move(i1 As Integer) 'NGアドレスを先頭へ移動
　　Cells(i1, 1).Interior.ColorIndex = 35 'エラーのメールアドレスに色をつける
　　If i1 = 1 Then Exit Sub '1行目がエラーの場合は、行移動は行わない(マクロエラーを防ぐため)
　　Rows(i1).Cut
　　Rows(1).Insert Shift:=xlDown
End Sub
'－－－－－－－－マクロコード－－－－－－－－終わり

お礼

私の質問などにこんなに詳しくコードを考えて下さってありがとうございます。かなりの貴重なお時間を割いていただいた事と思います。本当にありがとうございました。

回答No.1

s___o

>String変数中に全角文字が存在しているかどうかが一発でわかるような関数はないでしょうか。

StrConv(myCell, vbNarrow)
で、全角を半角に変換できます。

myCell = Trim(myCell)
の後に
myCell = StrConv(myCell, vbNarrow)
をすれば、

m = InStr(myCell, "＠")
If m <> 0 Then
Rows(i).Cut '先頭列へ移動
Rows(1).Insert Shift:=xlDown
は不要になります。

ElseIf n = 0 Then
↓
If n = 0 Then
にするのを忘れずに。

お礼

この様な事もマクロで可能なのですね。とても参考になりました！！ありがとうございます！！