[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA-データ抽出、転送方法』(aoki)vba初心者
いつも御世話になります。 固定項目をvbaにて入力できるようにしています。今度は入力されたデータを集計したいので すが、初っ端から行き詰まっています。まずやりたいのが、データの抽出、転送です。
(例=作業者ベースでの抽出
[抽出ボタン]
連番 コード 発生日 作業者 セクション
1 0707001 7/1 aoki layout 2 0707002 7/2 suzuki check 3 0707003 7/3 aoki layout 4 0707004 7/4 yamada layout 5 0707005 7/5 aoki layout 6 0707006 7/6 suzuki check
worksheet1 ↓
<<aoki>> 連番 コード 発生日 作業者 セクション 1 0707001 7/1 aoki layout 3 0707003 7/3 aoki layout 5 0707005 7/5 aoki layout
worksheet2
<<suzuki>> 連番 コード 発生日 作業者 セクション 2 0707002 7/2 suzuki check 6 0707006 7/6 suzuki check
このように抽出したいのですが、[抽出ボタン]を押したら「aoki」だけではなく、 一度に「suzuki」「yamada」も同じ形式で作業者別で別々のworksheetへ 同時に抽出、転送させたいです。 また、「作業者」も毎回変わり、一定の人物ではありません。 私自身、初心者独学の為、vbaでどこまでできるのかわかりません。 この程度なら全然簡単?無理がある?Accessならできる?等々、アドバイスを頂きたく。 (Accessは未経験。必要ならば勉強します。) どうぞ、簡単なアドバイスでも良いので何かありましたら宜しくお願いします。
フィルタオプションの設定で作業者フィールドの重複のないリストを任意の セル範囲へ作成する。 重複のない作業者リストをモトにリスト全体を作業者フィールドでフィルタリ ングし、シートを追加しながらフィルタ結果を転記していく。 最後に作成した重複のない作業者リストをDelete という流れで私ならコーディングするでしょう。 (みやほりん)(-_∂)b
アドバイス有難うございます。流れは何となくわかりました。やってみます。 また、報告か、解らなければ聞きます。^^;;;よろしくお願いします。 (aoki)
しかし、また壁にぶつかってしまったので教えてください。「繰り返し」処理についてです。現在行っている作業は、 >↑「重複のない作業者リストをモトにリスト全体を作業者フィールドでフィルタリングし、シートを追加しな がらフィルタ結果を転記していく。」です。(みやほりんさんアドバイス抜粋) 作業者リスト(上の表だと3人)を順番に抽出していく作業が上手く行きません。 今組んであるマクロの該当箇所です。
sheet"7月選出"→データベース sheet"A"→重複の無い作業者リスト AAA=重複の無い作業者とする
- - - - - - - - - - - - - - - - - - - - - - - - -
Worksheets("7月選出").Select
'↓シートAのセルA2を元にフィルタしデータを抽出する AAA = Worksheets("A").Range("A2").Value ←セルA2が作業者 Range("A5").AutoFilter Field:=4, Criteria1:=AAA
'↓シートAの後に新しいシートを挿入 Worksheets.Add after:=Worksheets("A"), Count:=1
'↓シート名をAAAとする ActiveSheet.Name = AAA '↓シート編集 Cells.Interior.ColorIndex = 36 Range("B3").Value = AAA Range("B3").Font.Bold = True Range("B3").Font.Size = 18 Range("B3").BorderAround Weight:=xlMedium, ColorIndex:=1 Range("B3").Interior.ColorIndex = 2
'↓抽出したデータを選択 Worksheets("7月選出").Select
'↓フィルタ部分を選択copy to シートAAA Range("A5").CurrentRegion.Copy Destination:=Worksheets(AAA).Range("B5")
'↓シートAAAの編集 Worksheets(AAA).Select Columns("B:O").EntireColumn.AutoFit Range("B5").CurrentRegion.BorderAround Weight:=xlMedium, ColorIndex:=1
'フィルタ解除 Worksheets("7月選出").AutoFilterMode = False
- - - - - - - - - - - - - - - - - - - - - - - - -
このマクロに繰り返し処理をどのように挿入していけばよろしいでしょうか? マクロ自体も初心者な為、グチャグチャだと思いますが 宜しくお願いします。(aoki)
横から失礼します。
i = 2 '2行目からスタート Do AAA = Worksheets("A").Range("A" & i).Value '←A列の作業者
'〜色々な処理〜
i = i + 1 '行数を更新
'A列が空白になったら終わり Loop Until Worksheets("A").Range("A" & i).Value = ""
こんな感じではどうでしょうか? (じゅんじゅん)
じゅんじゅん様様。アドバイス有難うございます。
上記マクロを書き込んだところ、動きました!m(__)m 解ってしまえばこんなにシンプルなことなのかと頭が下がります。 がっ!流れ的には問題ないのですが、出力されたデータが思うように行きませんでした。 というのは、作業者としている「AAA」の先頭が表示されません。aoki,suzuki,yamadaとすると、 aokiのシートができるのですが、フィルタで抽出されません。次にsuzukiですがyamadaのデータが 出力されている(ずれている)などの状態です。
sheet<<aoki>> 連番 コード 発生日 作業者 セクション - - - - - ←先頭はフィルタが掛かっているが 表示されない。 sheet<<suzuki>> 連番 コード 発生日 作業者 セクション 4 0707004 7/4 yamada layout ←suzukiのシートにyamadaのデータが。
sheet<<yamada>> 連番 コード 発生日 作業者 セクション 1 0707001 7/1 aoki layout ←最後yamadaのシートには全データが 2 0707002 7/2 suzuki check 表示されてしまう。 3 0707003 7/3 aoki layout 4 0707004 7/4 yamada layout 5 0707005 7/5 aoki layout 6 0707006 7/6 suzuki check
現状このような症状が出ています。コードに不備がないか、確認しているのですが見当たりません。 また、Loopを掛けず「aoki」のみで実行すれば正常にデータが表示されます。 上記コード(僕のマクロ)に問題があるのでしょうか? ここに書かれている情報で解るかわかりませんが、不備がありましたらアドバイスお願いします。 自分でも色々試して見ます。何度もすみません。じゅんじゅん様、皆様よろしくお願いします。 (aoki)
取り敢えず、上で提示されたコードを一部まとめてみました。
'↓シートAのセルA2を元にフィルタしデータを抽出する AAA = Worksheets("A").Range("A" & i).Value '←A列の作業者
'↓シートAの後に新しいシートを挿入 Worksheets.Add after:=Worksheets("A"), Count:=1
'↓シート名をAAAとする ActiveSheet.Name = AAA '↓シート編集 With Worksheets(AAA) .Cells.Interior.ColorIndex = 36 .Range("B3").Value = AAA .Range("B3").Font.Bold = True .Range("B3").Font.Size = 18 .Range("B3").BorderAround Weight:=xlMedium, ColorIndex:=1 .Range("B3").Interior.ColorIndex = 2 End With
'↓抽出したデータを選択 With Worksheets("7月選出") .Range("A5").AutoFilter Field:=4, Criteria1:=AAA
'↓フィルタ部分を選択copy to シートAAA .Range("A5").CurrentRegion.Copy Destination:=Worksheets(AAA).Range("B5") 'フィルタ解除 .AutoFilterMode = False End With
'↓シートAAAの編集 With Worksheets(AAA) .Columns("B:O").EntireColumn.AutoFit .Range("B5").CurrentRegion.BorderAround Weight:=xlMedium, ColorIndex:=1 End With どうでしょうか? (じゅんじゅん)
Sub TEST1() Dim TIT(50) As String * 10 Dim A(50) Dim I, J, K Dim CT1 CT1 = 1 For I = 1 To 1000 If (Sheet1.Cells(I, 3) = "") Then Exit For For J = 1 To 50 If (Trim(Sheet1.Cells(I, 3)) = Trim(TIT(J))) Then Exit For Next J If (J > CT1) Then TIT(CT1) = Sheet1.Cells(I, 3) A(CT1) = 1 CT1 = CT1 + 1 Worksheets.Add After:=Sheets(1) End If Next I
For I = 1 To 1000 If (Sheet1.Cells(I, 3) = "") Then Exit For For J = 1 To 50 If (Trim(Sheet1.Cells(I, 3)) = Trim(TIT(J))) Then For K = 1 To 4 Sheets(J + 1).Cells(A(J), K) = Sheet1.Cells(I, K) Columns(2).Select Selection.NumberFormatLocal = "m/d;@" Cells(1, 1).Select Next K A(J) = A(J) + 1 End If Next J Next I End Sub
皆様お楽しみ中のところ横から失礼します。 入力は SHEET1 として左端のタブにおいてください。(最大1000行を対象としてます) 結果はその右隣から横に展開します。(最大50SHEET分) よかったらご参考にしてください (mr_mangoos)
初めにdictionaryを用いて作業者名の重複を取り除いてます。 既に作業者名のシートがあれば強制的に削除し、新しく作り直します。
Sub Test() Dim Dic As Object Dim key As Variant Dim sh1 As Worksheet Dim sh2 As Worksheet Dim Csh As Worksheet Dim r As Range
Application.ScreenUpdating = False
Set sh1 = Worksheets("7月選出") Set Dic = CreateObject("Scripting.Dictionary")
With sh1 For Each r In .Range(.[D2], .Cells(Rows.Count, "D").End(xlUp)) Dic(r.Value) = Empty Next End With
For Each key In Dic.keys For Each Csh In Worksheets If key = Csh.Name Then Application.DisplayAlerts = False Csh.Delete Application.DisplayAlerts = True End If Next
Worksheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = key Set sh2 = Worksheets(key)
With sh2 .Cells.Interior.ColorIndex = 36 .Range("B3").Value = key .Range("B3").Font.Bold = True .Range("B3").Font.Size = 18 .Range("B3").BorderAround Weight:=xlMedium, ColorIndex:=1 .Range("B3").Interior.ColorIndex = 2 End With
With sh1 .Range("A5").AutoFilter Field:=4, Criteria1:=key .Range("A5").CurrentRegion.Copy Destination:=Worksheets(key).Range("B5") .AutoFilterMode = False End With
With sh2 .Columns("B:O").EntireColumn.AutoFit .Range("B5").CurrentRegion.BorderAround Weight:=xlMedium, ColorIndex:=1 End With Next
Set Dic = Nothing Set sh1 = Nothing Set sh2 = Nothing Application.ScreenUpdating = True End Sub
ご参考になれば。 (じゅんじゅん)
>じゅんじゅん様。有難うございます。 アドバイス頂いたマクロを軽くですが試してみたろ、上手く動きませんでした。 じっくり解読して、組み込んでみたいと思います。また結果、解らない箇所が ありましたら教えてください。m(__)m
>mr_mangoos様。なにやら凄そうなアドバイス頂いたようで。 現状まだ試すまでに至らないので少しずつ、参考にさせて頂きます。 有難うございす。m(__)m (aoki)
>>じゅんじゅん様。有難うございます。 >アドバイス頂いたマクロを軽くですが試してみたろ、上手く動きませんでした。 セルの番地が違っていたのでしょうか・・・? (じゅんじゅん)
>じゅんじゅん様。回答が遅くなりました。すみません。 マクロ上「ActiveSheet.Name = key」箇所がデバックとなってしまいます。 宜しくお願いします。(aoki)
>マクロ上「ActiveSheet.Name = key」箇所がデバックとなってしまいます。 エラー内容は何でしょうか? 新しいシートはできても、名前の変更が出来ていないと言う事でしょうか? もしかしたら、D列には空白などシート名に使えないものがありますか? (じゅんじゅん)
>worksheet「リスト」は作成されます。しかし、worksheet3(シート名が取得できていない?) が作成された時点で止まります。 「D列」ですが、空白、使用できない物は無いです。m(__)m (aoki)
>>worksheet「リスト」は作成されます。しかし、worksheet3(シート名が取得できていない?) >が作成された時点で止まります。 worksheet「リスト」がよくわかりませんが。
>マクロ上「ActiveSheet.Name = key」箇所がデバックとなってしまいます。 この時のエラー内容と、黄色く変わっている状態でkeyにカーソルを持って行くと key=○○○ ←○には作業者名が入っていますか? それとも違う値?
或いは、ブック・シート構成を私が勘違いしてるのかも・・・? (じゅんじゅん)
>worksheet「リスト」→「重複の無い作業者」シートです。すみません。 「key→Empty値」と表示されます。m(__)m (aoki)
私のコードはシート”7月選出”のD列の2行目から最終行までの値を、Dictionaryに放り込みますので、 その範囲内に”空白”が存在しているのではないでしょうか? ”7月選出”以外のシートは実行に影響しないと思うのですが・・・・? (じゅんじゅん)
>私のコードはシート”7月選出”のD列の2行目から最終行までの値を、Dictionaryに放り込みますので、 その範囲内に”空白”が存在しているのではないでしょうか? おっしゃる通りです。実質「D列」は5行目から始まり、現状テストで使用しているものだと、20行くらいまで しか埋まっていません。その他は空白のセルが存在します。m(__)m (aoki)
>With sh1 > For Each r In .Range(.[D2], .Cells(Rows.Count, "D").End(xlUp)) ↑ D5 に変更してみて下さい。 (じゅんじゅん)
じゅんじゅん様様様。今の僕にはちょっとレベルが高くて正直「目が点」です。 完璧に動きました。少しずつ解読しながらレベルアップしていきます。又、これで先に進めます。 本当に有難うございました。 m(__)m (aoki)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.