[[20070730174656]] 『VBA-データ抽出、転送方法』(aoki) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『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.