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

質問ですマクロをお願いします。
c:\test\以外にあるマクロ実行用ファイルのSheet2を参照して、データCSVファイルの内容をマクロ実行後の答えのように変換する。年齢Dは参照年齢コードGの数字を加算地域Eは_アンダーバーの前の数字を参照住所コードAとBの合致したもの。メールアドレスAはデータのドメインFと参照ドメインコードCとDの合致したものを@アットマークを加えてアドレスAにする。Fドメインは最後は削除する
?データCSVファイル20位データ行1ファイル2万行位(c:\test\のホルダー)
Aメルアド(aaaaa) B名前(ゲスト) C性別(1) D年齢(80) E住所(1_0) Fドメイン(1)
?参照はSheet2(c:\test\以外)
A住所コード(1) B住所(北海道) Cドメインコード(1) Dドメイン名(docomo.ne.jp) E性別コード(1) F性別(男性) G年齢コード(1800)
?マクロ実行後の答え表示
A B C D E
メルアド 名前 性別 年齢 住所
aaaaa@docomo.ne.jp ゲスト 男性 1880 北海道

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

▽最新の回答へ

1 ● online_p
●0ポイント

これは仕事です。


2 ● きゃづみぃ
●70ポイント ベストアンサー

とりあえず コメント欄と同様のものを 貼り付けておきます。

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 = 2 '開始する行

For b = kg To .Cells(kg, "A").End(xlDown).Row

'ドメイン取得

Set trow = ThisWorkbook.Sheets("Sheet2").Range("C:C").Find(What:=.Cells(b, "F"), LookIn:=xlValues)

If trow Is Nothing Then

'取得できなかった場合は そのまま

Else

.Cells(b, "A") = .Cells(b, "A") & "@" & ThisWorkbook.Sheets("Sheet2").Cells(trow.Row, "D")

End If


'性別取得

Set trow = ThisWorkbook.Sheets("Sheet2").Range("E:E").Find(What:=.Cells(b, "C"), LookIn:=xlValues)

If trow Is Nothing Then

'取得できなかった場合は そのまま

Else

.Cells(b, "C") = ThisWorkbook.Sheets("Sheet2").Cells(trow.Row, "F")

End If

'年齢

'加算するのは セルG2のみとする。

.Cells(b, "D") = .Cells(b, "D") + ThisWorkbook.Sheets("Sheet2").Cells(2, "G")

'住所

ad = .Cells(b, "E")

ck = InStr(1, ad, "_")

If ck > 1 Then

ad = Left(ad, ck - 1)

End If

Set trow = ThisWorkbook.Sheets("Sheet2").Range("A:A").Find(What:=ad, LookIn:=xlValues)

If trow Is Nothing Then

'取得できなかった場合は そのまま

Else

.Cells(b, "E") = ThisWorkbook.Sheets("Sheet2").Cells(trow.Row, "B")

End If

'F列は不要なので消去

.Cells(b, "F") = ""

Next b

End With

w.Save

w.Close

f = Dir

Loop

Application.DisplayAlerts = True

End Sub

◎質問者からの返答

ありがとうございます。

これからもよろしくおねがいします。

早速ですが先日のQ1305455789の分で追加の変更が

ありますので再度質問をさせていただきます。

関連質問


●質問をもっと探す●



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