人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

質問です
ホルダーC:\test\の中にエクセルCSVの複数ファイルがあります
対象データはメールアドレスデータでA列の1行目からあります
c:\test\のA列対象データ
aaaa@docomo.ne.jp
bbbb@ezweb.ne.jp
cccc@jcom.ne.jp

このデータの中から参照で指定するドメインが含まれる
メールアドレスの行を削除するマクロをお願いします

参照で指定する削除ドメインリストはマクロ実行ファイルの
参照ファイルsheet2のA列の1行目から複数あります

Sheet2のA列参照データ
docomo.ne.jp
ezweb.ne.jp

答え
c:\test\A列対象データ

cccc@jcom.ne.jp

だけが残ります

よろしくお願いします。

●質問者: inosisi
●カテゴリ:コンピュータ インターネット
✍キーワード:DoCoMo EZweb ne.jp test けが
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●50ポイント
Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Application.DisplayAlerts = False

If Worksheets("Sheet2").Range("A1") = "" Then Exit Sub
If Worksheets("Sheet2").Range("A2") = "" Then
 e = 1
Else
 e = Worksheets("Sheet2").Range("A1").End(xlDown).Row
End If

 
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
 Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
  '処理対象は 1番目のシートのみ。
 
 With w.Sheets(1)
 
 kg = 1  '処理終了行
 
 For gg = 1 To e
 If .Range("A1") = "" Then Exit For
 
 If .Range("A2") <> "" Then
 kg = .Range("A1").End(xlDown).Row
 Else
 Exit For
 End If
 
 For b = kg To 1 Step -1
 chk = ThisWorkbook.Worksheets("Sheet2").Cells(gg, "A").Value
 If Right(.Cells(b, "A"), Len(chk)) = chk Then
 .Rows(b).Delete Shift:=xlUp
 End If
 Next b
 Next gg
 End With
 
 w.Save
 w.Close
 f = Dir
Loop

Application.DisplayAlerts = True

End Sub

◎質問者からの返答

takntさん

ありがとうございます

データが多いと処理時間が問題ですね

早くする方法はありますか?

前回の質問の2011/07/17 09:13:45 の答えのマクロのほうが早いですね

sheet2の参照データと同じドメインを削除しないで

参照データ以外(残したいデータ)のデータをA列最後の行と空白あけてコピーしたら早くなりますか?(前回みたく)

よろしくお願いします。


2 ● km1981
●60ポイント ベストアンサー

これを実行してみてください

削除結果は [Sheet3] に入れます

Public Sub hatena()

Dim i1, i2, i3, n1, n2 As Integer

Dim adr As String

Dim ss As Variant

Dim flag As Boolean

n1 = Worksheets("Sheet1").Range("A1").End(xlDown).Row

n2 = Worksheets("Sheet2").Range("A1").End(xlDown).Row

i3 = 1

For i1 = 1 To n1

adr = Worksheets("Sheet1").Cells(i1, 1).Value

If (adr <> "") Then

ss = Split(adr, "@")

flag = False

For i2 = 1 To n2

If (ss(1) = Worksheets("Sheet2").Cells(i2, 1).Value) Then flag = True

Next i2

If (flag = False) Then

Worksheets("Sheet3").Cells(i3, 1).Value = adr

i3 = i3 + 1

End If

End If

Next i1

End Sub

◎質問者からの返答

ありがとうございます

結構処理速度は早い感じです。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ