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

質問です
c\test\のホルダー中にcsvファイルが複数あります
そのファイルの中のデータからメールアドレスの列のみをA列に置きそれ以外は削除する
列は多くて10列位です。文字列と数字の列です。途中に空白行がある場合のあります
マクロをお願いします。
データは2行目からですが移動する行は1行目からお願いします。
メールアドレスの列はA列からE列のいづれかに1列のみあります
abcde@docomo.ne.jpやacb@ezweb.ne.joなど必ず@マークは入っています
答え 以下のようにA列にメールアドレスの列を持ってくる
A列以外は削除する
A列
メールアドレス
abcde@docomo.ne.jp
abc@ezweb.ne.jp
よろしくマクロをお願いします。
列の数が固定されたほうが良い場合は決めますので質問ください



●質問者: inosisi
●カテゴリ:コンピュータ インターネット
✍キーワード:ABC CSV DoCoMo EZweb Ne
○ 状態 :終了
└ 回答数 : 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
 
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  '開始する行
 
 .Columns("A:A").Insert Shift:=xlToRight

 r = .Range("A1").SpecialCells(xlLastCell).Row
 c = .Range("A1").SpecialCells(xlLastCell).Column

 For b = 2 To c
 For d = 2 To r
 If InStr(1, .Cells(d, b), "@") > 0 Then
 .Cells(kg, "A") = .Cells(d, b)
 kg = kg + 1
 End If
 Next d
 Next b
 
 .Range(.Cells(1, 2), .Cells(r, c)).Delete Shift:=xlToLeft

 End With
 
 w.Save
 w.Close
 f = Dir
Loop

Application.DisplayAlerts = True

End Sub

◎質問者からの返答

ありがとうございます

こちらのメールデータの制度の都合で不敵格のデータが混じっていますので

エラーがでて止まるケースがあります。

今回はメール修正は最後にやるつもりです

できましたら

2行目以降10行目位のチェックでメールアドレスの列と判断してコピーするマクロ

指示はできますか。

こちらの勝手で申し訳ございません

よろしくおねがいします。


2 ● きゃづみぃ
●50ポイント

For d = 2 To r

が r の行(データの最後の行)まで やるようにしていますので

これを

For d = 2 To 10

に変えれば 2行目から10行目までとなります。

関連質問


●質問をもっと探す●



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