[[20140419095634]]　『横方向（列）の繰返し方』（りん）　ページの最後に飛ぶ

『横方向（列）の繰返し方』（りん）

 横方向（列）の繰返し方を教えてください。

 下のコードを書いてみました。貼り付け先は横方向に4列ずつずれます。
 .AutoFilter Field:=3には規則性のない3ケタのコードが10個程度入っていて、
 上から順番に選択、コピー貼り付けを繰り返します。

    .AutoFilter Field:=3の最後までを選択、
    コピー貼り付けを実行後、
    .AutoFilter Field:=2で"MilK"を選択し、
    .AutoFilter Field:=3の上から順番に選択、
 コピー貼り付けを繰り返したいのですが、どう書けばよいのでしょうか？

 For i = 1 To 1000 Step 4と書くのかなと思うのですが、Cells(1,i)=の後を
 どう書けば良いのかわかりません。
 また、「.AutoFilter Field:=3の上から順番に最後まで選択、コピー貼り付けを繰返す」
 というやり方があれば教えていただけますか？

 よろしくお願いいたします。

 Sub データ管理()
 '' .AutoFilter Field:=3には規則性のない3桁コードが10個程度入っています。
 ''上から順に選択、コピー貼り付けを行います。

    With Sheets("Material").Range("A1")
        .AutoFilter Field:=1, Criteria1:="Custerd"
        .AutoFilter Field:=2, Criteria1:="Egg"
        .AutoFilter Field:=3, Criteria1:="001"
        .CurrentRegion.Copysheets("Strage").Range ("A1")
    End With

    With Sheets("Material").Range("A1")
        .AutoFilter Field:=1, Criteria1:="Custerd"
        .AutoFilter Field:=2, Criteria1:="Egg"
        .AutoFilter Field:=3, Criteria1:="128"
        .CurrentRegion.Copysheets("Strage").Range ("E1")
    End With

 '' .AutoFilter Field:=3の最後までを選択、コピー貼り付けが終わると、
 '' .AutoFilter Field:=2, Criteria1:="Milk"を選択し、
 '' .AutoFilter Field:=3を上から順に選択、コピー貼り付けを行います。

    With Sheets("Material").Range("A1")
        .AutoFilter Field:=1, Criteria1:="Custerd"
        .AutoFilter Field:=2, Criteria1:="Milk"
        .AutoFilter Field:=3, Criteria1:="005"
        .CurrentRegion.Copysheets("Strage").Range ("AM1")
    End With

    With Sheets("Material").Range("A1")
        .AutoFilter Field:=1, Criteria1:="Custerd"
        .AutoFilter Field:=2, Criteria1:="Milk"
        .AutoFilter Field:=3, Criteria1:="008"
        .CurrentRegion.Copysheets("Strage").Range ("AQ1")
    End With

 End Sub
（りん）

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

 文章が長くて読みずらかったので、適当に改行を入れさせてもらいました。

 フィルターしたものを順番に処理するというほうが素直かもしれませんが、
 Dictionary を使用して、あらかじめ候補を準備して置くやり方の例です。
 （データがA:C列だけなら、辞書を展開すればオートフィルタ無しでもでき
 そうですけれど。）

 ご参考まで。

 Sub Sample()
    Const category = "Custerd"

    Dim objDic
    Set objDic = CreateObject("Scripting.Dictionary")
    Dim r As Long
    For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(r, "A").Value = category Then
            If objDic.Exists(Cells(r, "B").Value) = False Then
                Set objDic(Cells(r, "B").Value) = CreateObject("Scripting.Dictionary")
            End If
            objDic(Cells(r, "B").Value)(Cells(r, "C").Value) = True
        End If
    Next

    Dim key
    Dim subKey
    Dim c As Long
    c = 5
    For Each key In objDic.keys
        For Each subKey In objDic(key).keys
            With Sheets("Material").Range("A1")
                .AutoFilter Field:=1, Criteria1:=category
                .AutoFilter Field:=2, Criteria1:=key
                .AutoFilter Field:=3, Criteria1:=subKey
                .CurrentRegion.Copy Sheets("Strage").Cells(1, c)
            End With
            c = c + 4
        Next
    Next
 End Sub

（Mook） 2014/04/19(土) 13:15

Mookさん、さっそくのお答をありがとうございます。
私が書いた質問を読みやすく編集していただいて、これまたありがとうございます。
今度はフォントが大きいのですが、小さくできませんでした。
下から4行も修正できませんでした。
読みづらいかもしれませんがご容赦ください。

データが会社にあるため、教えていただいたコードを月曜日まで試すことができないのですが、
データはA列からD列まででして、下の表の様になっています。
＊左端は行番号です。数字が飛んでいるのは間に非表示の行があるためとご理解ください。

行は7000行ほどあるのですが、「Strage」シートに貼り付けたいのは
1.「Custerd」、「Milk」を選択、コードは上から順番に選択し、表示されているセルをコピー、
　「Strage｣シートに貼り付け。
2.「Custerd」、「Egg」を選択、以下1.と同じ。
3.「Chocolate」、「Cacao」を選択、以下1.と同じ。
4.「Chocolate」、「Butter」を選択、以下1.と同じ。
貼り付け先は横に4列ずつずれます。
最初の質問「Chocolate」を書いていませんでした。すみません。
こういう場合もDictionaryでできるのでしょうか？

	A	B	C	D
1	商品	原材料	コード	単価
2	Custerd	Milk	001	200
3	Custerd	Milk	001	180
4	Custerd	Milk	001	190
5	Custerd	Milk	001	150
6	Custerd	Milk	101	190
20	Custerd	Milk	256	50
21	Custerd	Milk	256	80
22	Custerd	Milk	256	60
30	Custerd	Egg	002	150
40	Custerd	Egg	202	50
50	Custerd	Vanila	156	200
100	Chocolate	Milk	001	200
120	Chocolate	Sugar	003	180
130	Chocolate	Cacao	601	200
140	Chocolate	butter	004	150

（りん） 2014/04/19(土) 14:52

 複数商品に対応するように変更した例です。
 見比べてどう変更したかを理解すると良いかと思います。

 Public c As Long
 Sub Sample()
     c = 5
     Worksheets("Strage").Cells.ClearContents
     MakeList "Custerd"
     MakeList "Chocolate"
     Worksheets("Material").AutoFilterMode = False
 End Sub

 Sub MakeList(category As String)
    Dim objDic
    Set objDic = CreateObject("Scripting.Dictionary")
    Dim r As Long
    With Worksheets("Material")
    For r = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
        If .Cells(r, "A").Value = category Then
            If objDic.Exists(.Cells(r, "B").Value) = False Then
                Set objDic(.Cells(r, "B").Value) = CreateObject("Scripting.Dictionary")
            End If
            objDic(.Cells(r, "B").Value)(.Cells(r, "C").Value) = True
        End If
    Next
    End With

    Dim key
    Dim subKey
    For Each key In objDic.keys
        For Each subKey In objDic(key).keys
            With Worksheets("Material").Range("A1")
                .AutoFilter Field:=1, Criteria1:=category
                .AutoFilter Field:=2, Criteria1:=key
                .AutoFilter Field:=3, Criteria1:=subKey
                .CurrentRegion.Copy Worksheets("Strage").Cells(1, c)
            End With
            c = c + 4
        Next
    Next
 End Sub
（Mook） 2014/04/19(土) 15:32

Mookさん、お礼が遅くなり済みませんでした。
願いどおりの貼り付けができました！
ありがとうございました。

もうひとつ教えていただけるなら嬉しいのですが、
上では選択していなかったField:4の選択を追加し、表示されたうちの
E列のみをコピーし、"Strage"シートのA1から横向きに貼り付け付けていくことは
可能でしょうか？
.AutoFilter Field:=1, Criteria1:="Custerd"
　　　　.AutoFilter Field:=2, Criteria1:="Milk"

        .AutoFilter Field:=3, Criteria1:="001"
        .AutoFilter Field:=4, Criteria1:="150"

"Strage"シートのA1に評価
A2に○
A3に○

その次は
.AutoFilter Field:=1, Criteria1:="Custerd"

        .AutoFilter Field:=2, Criteria1:="Milk"
        .AutoFilter Field:=3, Criteria1:="001"
        .AutoFilter Field:=4, Criteria1:="190"

"Strage"シートのB1に評価
B2に△

	A	B	C	D	E
1	商品	原材料	コード	単価	評価
2	Custerd	Milk	001	200	×
3	Custerd	Milk	001	150	○
4	Custerd	Milk	001	190	△
5	Custerd	Milk	001	150	○
6	Custerd	Milk	101	190	○
20	Custerd	Milk	256	50	○
21	Custerd	Milk	256	80	○
22	Custerd	Milk	256	60	○
30	Custerd	Egg	002	150	○
40	Custerd	Egg	202	50	○
50	Custerd	Vanila	156	200	○
100	Chocolate	Milk	001	200	○
120	Chocolate	Sugar	003	180	○
130	Chocolate	Cacao	601	200	○
140	Chocolate	butter	004	150	○

（りん） 2014/04/23(水) 20:46

 質問が継続していたようですが、見落としていました。

 四列目のフィルタ条件はどうやって指定するのでしょうか。
 また、検索結果は必ず１つに絞られるのでしょうか。

 データサンプルだけでなく、出力結果がどうなるかサンプル提示してもらえるでしょうか。

 ただ上記を見る限りは、オートフィルタを使用しなくとも、単純に条件にマッチしたデータを
 羅列すればよいような気がします。

（Mook） 2014/04/26(土) 08:32

Mookさん、お返事をいただけて嬉しいです。ありがとうございます。
四列目のフィルタ条件も三列目と同様に、数値を昇順で選択します。
Field:=1とField:=2は名前を指定、
Field:=3とField:=4は昇順で順番に選択します。
出力結果は以下の様になればうれしいです。
どうぞよろしくお願いします。

		A	B	C	D	E
1(商  品)	Custerd	Custerd	Custerd	Custerd	Custerd
2(原材料)	Milk	Milk	Milk	Milk	Milk
3(コード)	001	001	001	001	101
4(単  価)	150	180	190	200	150
5(評  価)	○	△	○	△	○
6		○	△	○	○	△
7		△	△	△	○	△
8		△	○	△	○	△
9		△	○	△	○	△
10		○	○	○	○	○
11		×	○	×	△	×
12		○	○	○	△	○
13		○	△	○	○	○
14		○	△	△	○	△
15		△	○	△		△
16		×	○	○		○
17		○		○		○
18		○		○		○
19		○		○		×
20		○				○

（りん） 2014/04/27(日) 11:47

 これまでの内容と変わりますが、話を聞くとオートフィルタよりデータの並べ替えの方が
 簡単なような気がしました。

 内容を理解するためには
 一度シートを見ながらステップ実行（F8）してみてはどうでしょうか。

 Sub Sample()
    Const category = "Custerd"
    Dim ws As Worksheet
    Worksheets("Sheet1").Copy
    Set ws = ActiveSheet

    '// 対象シートをコピーして並べ替え
    Dim rc As Long
    rc = ws.Cells(Rows.Count, "A").End(xlUp).Row
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("A2").Resize(rc - 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("B2").Resize(rc - 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("C2").Resize(rc - 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("D2").Resize(rc - 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange Range("A1").Resize(rc, 5)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    '// 一旦データをクリア。書式は文字列に。
    ThisWorkbook.Worksheets("Strage").Cells.ClearContents
    ThisWorkbook.Worksheets("Strage").Cells.NumberFormatLocal = "@"

    '// 対象データの転記
    Dim ky As String
    Dim preKey As String
    Dim r As Long
    Dim c As Long
    Dim sr As Long
    For r = 2 To rc
        If ws.Cells(r, "A").Value = category Then
            '// B～D で比較
            ky = ws.Cells(r, "B").Value & "_" & ws.Cells(r, "C").Value & ws.Cells(r, "D").Value
            If ky <> preKey Then '// 前と違ったら列を変更
                c = c + 1
                ThisWorkbook.Worksheets("Strage").Cells(1, c).Resize(4, 1) = Application.Transpose(ws.Cells(r, "A").Resize(1, 4))
                preKey = ky
                sr = 5
            End If
            ThisWorkbook.Worksheets("Strage").Cells(sr, c).Value = ws.Cells(r, "E").Value
            sr = sr + 1
        End If
    Next

    '// 作業シートの削除
    ws.Parent.Close False
 End Sub
（Mook） 2014/04/27(日) 19:01

Mookさん、ありがとうございます！
教えていただいたコードを一目見たとき、あまりにも難しそうでギョッとしましたが
何度も読んでいるうちに少しずつわかってきました。

初めはフィルターで必要事項を選択、コピーし、別シートに貼り付けた後
手動で「以下の様になれば・・・」という形にし、不要な列を削除する、
というやり方が私にとっての最善策だったのですが、
こんなことができるのですね。
まだ感動しています。

全てを理解するのはもう少しかかりそうですが、先に教えていただいた
方法とともに自分のものにできるよう頑張ります。

私の拙い説明に真摯にこたえてくださって、本当にありがとうございました。

（りん） 2014/04/28(月) 21:17

コメント返信：

[ 一覧(最新更新順) ]

[[20140419095634]] 『横方向（列）の繰返し方』（りん） ページの最後に飛ぶ

[[20140419095634]]　『横方向（列）の繰返し方』（りん）　ページの最後に飛ぶ