[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『横方向(列)の繰返し方』(りん)
横方向(列)の繰返し方を教えてください。
下のコードを書いてみました。貼り付け先は横方向に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
データが会社にあるため、教えていただいたコードを月曜日まで試すことができないのですが、
データは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
もうひとつ教えていただけるなら嬉しいのですが、
上では選択していなかった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
質問が継続していたようですが、見落としていました。
四列目のフィルタ条件はどうやって指定するのでしょうか。 また、検索結果は必ず1つに絞られるのでしょうか。
データサンプルだけでなく、出力結果がどうなるかサンプル提示してもらえるでしょうか。
ただ上記を見る限りは、オートフィルタを使用しなくとも、単純に条件にマッチしたデータを 羅列すればよいような気がします。
(Mook) 2014/04/26(土) 08:32
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
初めはフィルターで必要事項を選択、コピーし、別シートに貼り付けた後
手動で「以下の様になれば・・・」という形にし、不要な列を削除する、
というやり方が私にとっての最善策だったのですが、
こんなことができるのですね。
まだ感動しています。
全てを理解するのはもう少しかかりそうですが、先に教えていただいた
方法とともに自分のものにできるよう頑張ります。
私の拙い説明に真摯にこたえてくださって、本当にありがとうございました。
(りん) 2014/04/28(月) 21:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.