質問ですマクロをお願いします。

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  北海道

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/05/19 12:53:57
  • 終了:2011/05/21 14:03:38

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13538ベストアンサー獲得回数11982011/05/21 12:19:42

ポイント70pt

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

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

id:inosisi4141

ありがとうございます。

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

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

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

2011/05/21 14:03:08

その他の回答(1件)

id:online_p No.1

online_p回答回数1153ベストアンサー獲得回数592011/05/19 22:04:22

これは仕事です。

id:taknt No.2

きゃづみぃ回答回数13538ベストアンサー獲得回数11982011/05/21 12:19:42ここでベストアンサー

ポイント70pt

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

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

id:inosisi4141

ありがとうございます。

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

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

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

2011/05/21 14:03:08
  • id:taknt
    Sheet2の内容(項目とその内容の例)とCSVの例があれば わかりやすいと思う。

    画面をキャプチャしたのを はてなのフォトライフとかに入れたら簡単です。
  • id:inosisi4141
    お世話様です
    前回質問の1304040648の参照Sheet2に性別と年齢を追加しました
    年齢は参照に置くまでもなくデータcsvの年齢に1800を加えた数字が答えです。
    参照から外してもかまいません。
    性別も男性の1と女性の0のいずれかですから参照からはずしてもかまいません
    性別は男性か女性いずれかです混在はありません。
    c:\test\の中でファイルが一括で変換できればよいと思ってマクロをお願いしました。
    住所コードの隣に住所
    ドメインコードの隣にメールアドレス
    と住所コードとドメインコード欄が残ってもかまいません

    フォトライフは見えましたか
    よろしくお願いします
  • id:taknt
    だいたい やりたいことが理解できましたので これから 作ってみます。
  • id:inosisi4141
    お世話様です。
    よろしくお願いします。
  • id:taknt
    締め切り状態なので こちらに

    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


  • id:inosisi4141
    takntさん
    ありがとうございました。
    上手くゆきました。完璧です。
    遅くなってすみません。
    また何かありましたら質問しますので
    今後ともよろしくお願いします。
  • id:inosisi4141
    takntさん
    回答欄の記入おねがいします
    質問を終了しますのでよろしくお願いします。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません