今月からマクロの勉強を始めたばかりの素人です
仮に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ベストアンサー
- 回答日時:
#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
- 回答日時:
こんにちは。
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
- 回答日時:
#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 です。メールアドレスのチェックなら正規表現を使った関数を作れば良いと思います。
コード中のマッチングパターンを変更すれば、特定ドメインだけマッチする、、
といったチェックも可能です。
それをループ処理の中で使えば良いかと思います。
注意)下記の関数に書いたマッチングパターンはあくまで
「メールアドレスの書式として正しいか?」
の判定であって、実在するアドレスかどうかまではチェックしてません。
'// メールアドレス チェック関数
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
- 回答日時:
こんばんわ。
メールアドレスの付け方には、規則があります。
例えば、使える文字は全て半角で、アルファベットの小文字(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
- 回答日時:
>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
にするのを忘れずに。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) Excelマクロ Application.Run 5 2023/06/17 15:16
- Visual Basic(VBA) Excelにて、シート1の行を削除するとシート2のシート1と同じ番号の行も削除したい 3 2022/05/08 04:24
- Visual Basic(VBA) 特定の文字を簡単な操作で半角スペースに変換するか削除したい 2 2022/11/01 10:35
- Visual Basic(VBA) ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています 17 2022/12/07 12:03
- Excel(エクセル) 【マクロ】フォルダAからダBへファイルを、ファイルの更新日時の条件で、1つづつ移動するには? 3 2022/08/25 09:56
- Excel(エクセル) VBAで組み合わせ算出やCOUNTIFSの処理を高速化したいです。 4 2022/04/07 02:38
- Visual Basic(VBA) エクセルのマクロで対象ごとにシート分けしてその内容をセルに書き込みたい 9 2022/08/24 13:23
- Excel(エクセル) マクロで最終行から上に検索を逆にしたい 1 2022/05/17 18:27
- Visual Basic(VBA) 【VBA】特定のワードが入っている行全体を塗りつぶしたい 4 2022/04/20 15:22
- Visual Basic(VBA) VBA 行削除した連番 4 2023/06/27 16:00
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
LINE TCBというところからLINE...
-
インスタの捨て垢で友達のスト...
-
メールアドレスから個人を特定...
-
星の王子さまというアプリで、 ...
-
大学定期試験過去問サイト「過...
-
インスタのアカウントの消し方...
-
インスタグラムでブロックされ...
-
カカオで退会せずに、アプリだ...
-
インスタで高校生からオフパコ...
-
携帯電話を解約してもSMSの受信...
-
Excelのセルにユーザー名...
-
ぷららの相手にだけメールの送...
-
WeChatで自分のアカウントが何...
-
解約済みの iPadについて 解約...
-
ビーリアルのユーザー名を変え...
-
YouTubeMusicのログアウト方法...
-
カカオトークについて教えてく...
-
中学生男子です。 Twitterなど...
-
インスタのアイコンについてるN...
-
LINE Payで友だちに送金しよう...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ビーリアルのユーザー名を変え...
-
Excelのセルにユーザー名...
-
メールをパスワードつきで送る方法
-
steam版 apexのログアウト方法...
-
メールエラー
-
LINE TCBというところからLINE...
-
URLとメールアドレス
-
メールアドレスで上付きのハイフン
-
インスタのアイコンについてるN...
-
メールアドレス 上バーの入力...
-
ユニクロやGUのシフト管理アプ...
-
携帯電話を解約してもSMSの受信...
-
メールアドレスから個人を特定...
-
インスタの捨て垢で友達のスト...
-
スタディプラスではアカウント...
-
Instagramからこんなメールがき...
-
YouTubeが毎回ログインしないと...
-
メールを返信したら、英語のメ...
-
解約済みの iPadについて 解約...
-
メールのマナー編
おすすめ情報