[[20140318114455]]　『CSVファイルを読み込み、特定の項目の行だけ新規ａx（とも）　ページの最後に飛ぶ

『CSVファイルを読み込み、特定の項目の行だけ新規にシートに展開する方法』（とも）

 こんにちは。はじめまして。エクセル初心者です。

 もしよろしければご教授お願いいたします。

 CSVファイルを読み込んだ結果、
 ある特定の列と項目だけを表示させたいのですが、
 マクロを教えて得ていただけないでしょうか？

 -------　CSVファイル　-----------
 国名　管理　項目1　項目2　項目3　項目4　項目5　・・・・・　
 A　　　○　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 B　　　×　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 C　　　○　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 A　　　○　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 A　　　×　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 C　　　○　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 A　　　○　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・
 A　　　×　　XXX　　XXX　　XXX　　XXX　　XXX　　・・・・

 -------　エクセルファイル（Sheet1)　-----------
 「読み込みのボタン」
 「国名」：　A　（←選択可能）
 「管理」：　○　（←選択可能）
 「表示」：　項目１、項目3、項目5（←選択可能）

 -------　読み込み結果ファイル(新規シート）　-----------
 国名　管理　項目1　項目3　項目5
 A　　　○　　XXX　　XXX　　XXX
 A　　　○　　XXX　　XXX　　XXX

 こんなものフィルタをかけて手作業でやれ！
 と思われる方が多いと思いますが、
 本工程が頻繁に行われているため。
 なるべく簡素化したいため、
 よろしければマクロを教えていただけないでしょうか。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 Sheet1 にデータが有り、1行目が列見出しになっている。
 Sheet2 の:
     B1 に 国名
     B2 に 管理
     B3 に 表示される項目が 項目2、項目5、項目1 のように "、"(全角の点) で区切られている

 との想定で

 1) B3の順番を無視した場合

 Sub byFilter()
    Dim Cntry As String, mng As String, myItems
    Dim i As Long, e, x, msg, rng As Range
    With Sheets("sheet2")
        Cntry = .Range("b1").Value
        mng = .Range("b2").Value
        myItems = Split(.Range("b3").Value, "、")
        .Range("a6").CurrentRegion.Clear
    End With
    With Sheets("sheet1").Cells(1).CurrentRegion
        .Parent.AutoFilterMode = False
        For i = 0 To UBound(myItems)
            x = Application.Match(myItems(i), .Rows(1), 0)
            If IsNumeric(x) Then
                myItems(i) = x
            Else
                msg = "項目名が不明": Exit For
            End If
        Next
        If IsEmpty(msg) Then
            .AutoFilter 1, Cntry
            .AutoFilter 2, mng
            Set rng = .Columns("a:b")
            For Each e In myItems
                Set rng = Union(rng, .Columns(CLng(e)))
            Next
            rng.Copy Sheets("sheet2").Range("a6")
            .AutoFilter
        End If
    End With
    If Len(msg) Then MsgBox msg
 End Sub

 2) B3の順番通りに表示させる場合

 Sub byEvaluate()
    Dim Cntry As String, mng As String, myItems, i As Long, x, msg, y
    With Sheets("sheet2")
        Cntry = .Range("b1").Value
        mng = .Range("b2").Value
        myItems = Split("、、" & .Range("b3").Value, "、")
        .Range("a6").CurrentRegion.Clear
    End With
    With Sheets("sheet1").Cells(1).CurrentRegion
        For i = 2 To UBound(myItems)
            x = Application.Match(myItems(i), .Rows(1), 0)
            If IsNumeric(x) Then
                myItems(i) = x
            Else
                msg = "項目名が不明": Exit For
            End If
        Next
        If IsEmpty(msg) Then
            myItems(0) = 1: myItems(1) = 2
            x = Filter(.Parent.Evaluate("transpose(if((row(" & .Address & ")=1)+((" & _
            .Columns(1).Address & "=""" & Cntry & """)*(" & .Columns(2).Address & "=""" & _
            mng & """)),row(1:" & .Rows.Count & "),char(2)))"), Chr(2), 0)
            If UBound(x) > 0 Then
                x = Application.Transpose(Application.Index(Application.Transpose(.Value), _
                Evaluate("row(1:" & .Columns.Count & ")"), x))
                Sheets("sheet2").Range("a6").Resize(UBound(x), UBound(myItems) + 1).Value = _
                Application.Index(x, Evaluate("row(1:" & UBound(x) & ")"), myItems)
            Else
                Sheets("sheet2").Range("a6").Resize(, UBound(myItems) + 1).Value = _
                Application.Index(.Value, 0, myItems)
            End If
        End If
    End With
    If Len(msg) Then MsgBox msg
End Sub
（seiya） 2014/03/18(火) 13:12
 2) で検索対象データが無い場合のエラー処理を追加 13:25

コメント返信：

[ 一覧(最新更新順) ]

[[20140318114455]] 『CSVファイルを読み込み、特定の項目の行だけ新規ａx（とも） ページの最後に飛ぶ

[[20140318114455]]　『CSVファイルを読み込み、特定の項目の行だけ新規ａx（とも）　ページの最後に飛ぶ