[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『オートフィルタのマクロ』（sachi）
マクロ初心者です。
オートフィルタで抽出したデータをコピーして別シートに貼り付ける
作業をマクロの自動記録でやってみましたがうまく応用できないので教えて下さい。
「計算用シート1」シートに4人分のデータが並んでいます。
1人目→D4:I183 2人目→J4:O183 3人目→P4:U183 4人目→V4:AA183
このデータをまず見積業務という項目に該当するもののみに絞込み、「Sheet1」にコピペする作業を
4人分行う。4人分のコピペが終わったら「Sheet1」のデータをフィルタのオプション設定で重複するレコードを除き、抽出されたデータを「計算用シート見積り」シートに貼り付ける
次に予測業務という項目に該当するもののみに絞込み、同じ作業をして抽出されたデータを「計算用シート予測」に貼り付ける
以上の作業を毎月行いたいのですが、「計算用シート1」で抽出したデータのコピペの
範囲は毎回変わるので、オートフィルタで抽出された範囲を指定できるようにしたい
のですが、どのように直したらいいのかわかりません。
また見積業務と予測業務は人によって該当無しの場合があります。今回の場合は3人目と
4人目が予測業務無しです。毎月状況が変わるのですが、次月3人目と4人目に予測業務が
発生した時に同じ処理をするためにはどうしたらいいのでしょうか。
わかりにくい説明ですみませんが、よろしくお願い致します。
Sub Macro1()
Selection.AutoFilter Field:=1, Criteria1:="見積業務"
ActiveWindow.SmallScroll Down:=-3
Range("D22:G136").Select
Selection.Copy
Sheets("Sheet1").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("計算用シート1").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=7, Criteria1:="見積業務"
Range("J4:M4").Select
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.SmallScroll Down:=12
Range("A31").Select
ActiveSheet.Paste
Sheets("計算用シート1").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=7
Selection.AutoFilter Field:=13, Criteria1:="見積業務"
ActiveWindow.SmallScroll ToRight:=8
Range("P4:S30").Select
Selection.Copy
Sheets("Sheet1").Select
Range("A32").Select
ActiveSheet.Paste
Sheets("計算用シート1").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=13
Selection.AutoFilter Field:=19, Criteria1:="見積業務"
Range("V22:Y144").Select
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.SmallScroll Down:=15
Range("A44").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-45
Range("A1:D9").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Range("A1:D86").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("A2:D77").Select
Selection.Copy
Sheets("計算用シート見積り").Select
Range("D4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Select
Application.CutCopyMode = False
ActiveSheet.ShowAllData
Selection.ClearContents
Sheets("計算用シート1").Select
ActiveWindow.SmallScroll Down:=-42
ActiveWindow.LargeScroll ToRight:=0
Selection.AutoFilter Field:=19
ActiveWindow.LargeScroll ToRight:=-1
Selection.AutoFilter Field:=1, Criteria1:="予測業務"
Range("D172:G173").Select
Selection.Copy
Sheets("Sheet1").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("計算用シート1").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=7, Criteria1:="予測業務"
Range("J40:M41").Select
Selection.Copy
Sheets("Sheet1").Select
Range("A4").Select
ActiveSheet.Paste
Sheets("計算用シート1").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=7
ActiveWindow.SmallScroll ToRight:=10
Sheets("Sheet1").Select
Range("A1:D5").Select
Range("A1:D5").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("A2:D3").Select
Selection.Copy
Sheets("計算用シート予測").Select
Range("D4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.ShowAllData
Range("A4:D5").Select
Selection.ClearContents
Sheets("計算用シート1").Select
End Sub
Excel2000 Windows
言葉だけではシートのデータの状態がわからないので質問のポイントがわかりません。
各シートのレイアウトと簡単で良いので実際に近いデータを掲示できませんか？ もちろん社内情報や個人情報には配慮していただく形で。
（ｍｏｍｏ）
momo様
シートの状態ですが、「計算用シート1」シートに下記の表があります。
D E F G H I
3行目 区分 部品名 段階 詳細 予測工数 実績工数 ←見出し
4行目 予測業務 AAA 試作 検証作業 2.00 2.50 ←以降183行目まで該当項目入力
D4からD183の区分に入力されるのが、見積業務もしくは予測業務でこれをキーにオートフィルタで データを抽出し、DからG列をコピーして「Sheet1」に貼り付けます。 「計算用シート1」にはH列以降に同様の項目が3人分あるので、オートフィルタでのデータ抽出と 「Sheet1」へのコピペを人数分繰り返します。 区分から詳細の組み合わせが2000件ほどあり、重複することもあるので、重複したものを削除してから 見積業務は「計算用シート見積り」シートへ、予測業務は「計算用シート予測」へコピペ。
計算用シート見積りと計算用シート予測は下記の通り
1人目 2人目
A B D E F G H I J K
3行目 区分 部品名 段階 詳細 予測工数 実績工数 予測工数 実績工数
D4セルに抽出データを貼り付けるとH列以降に関数式を入れてあるので、各担当者の工数合計が表示 され、A、B列で予測と実績工数の総合計を出します。
これでおわかりになるでしょうか？すみませんが、よろしくお願い致します。
(sachi)
要するに「計算用シート1」シートのD:G列の重複の無いリストを 見積業務と予測業務別に作りたい。という事でよろしいでしょうか？
だとして オートフィルターですと項目ごとに探さなければならないので結構大変ですよね？ Dictionaryオブジェクトを使って処理する方法にしてみてはどうでしょうか？
最初はコードを見てもわからないかもしれませんが ヘルプやネットで調べていくうちに解るようになると思います。 非常に使いやすくて便利なオブジェクトなので勉強してみてください。
Sub test()
Dim myDic(1 To 2) As Object
Dim i As Long, j As Long
Dim tbl As Variant, buf As String
For i = 1 To 2
Set myDic(i) = CreateObject("Scripting.Dictionary")
Next i
For i = 4 To 22 Step 6
With Worksheets("計算用シート1")
tbl = .Range(.Cells(4, i), .Cells(183, i + 4)).Value
End With
For j = 1 To UBound(tbl)
buf = tbl(j, 1) & vbTab & tbl(j, 2) & vbTab & tbl(j, 3) & vbTab & tbl(j, 4)
Select Case tbl(j, 1)
Case "見積業務"
If Not myDic(1).Exists(buf) Then
myDic(1).Add buf, ""
End If
Case "予測業務"
If Not myDic(2).Exists(buf) Then
myDic(2).Add buf, ""
End If
End Select
Next j
Next i
With Worksheets("計算用シート見積り").Range("D4").Resize(myDic(1).Count)
.Value = Application.Transpose(myDic(1).keys)
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
End With
With Worksheets("計算用シート予測").Range("D4").Resize(myDic(2).Count)
.Value = Application.Transpose(myDic(2).keys)
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
End With
End Sub
（ｍｏｍｏ）
momo様
教えて頂いたコードを貼り付けて試してみましたが、下記のところでアプリケーション定義または
オブジェクトの定義エラーですというエラーが出ました。
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
ヘルプを見てみたりしたのですが、どこをどう修正したらいいのかわかりません。 それから「計算用シート1」シートのD:G列に加えてJ:M列とP:S列とV:Y列の重複の無いリストを 作りたい（計算用シート見積りと計算用シート予測で4人分の合計工数を計算する為）のですが、 その場合は、どの辺りを修正すればいいのでしょうか？頼りきりですみません…
(sachi)
エラーはエクセル２０００だからですかね データ区切りの引数の違いがあるかもしれませんが、私が２０００の環境が無いので 少しお待ち下さい。 依存しないコードに書き換えてみます。
あとJ:M P:S V:Y についてはすでに対応済みのコードです。
ちょっと待ってくださいね。 （ｍｏｍｏ）
なるべくバージョンに依存しないように書いてみましたので テストしてみてください。
Sub test()
Dim myDic(1 To 2) As Object
Dim i As Long, j As Long
Dim tbl As Variant, buf As String
For i = 1 To 2
Set myDic(i) = CreateObject("Scripting.Dictionary")
Next i
For i = 4 To 22 Step 6
With Worksheets("計算用シート1")
tbl = .Range(.Cells(4, i), .Cells(183, i + 3)).Value
End With
For j = 1 To UBound(tbl)
buf = tbl(j, 1) & vbTab & tbl(j, 2) & vbTab & tbl(j, 3) & vbTab & tbl(j, 4)
Select Case tbl(j, 1)
Case "見積業務"
If Not myDic(1).Exists(buf) Then
myDic(1).Add buf, Application.Index(tbl, j, 0)
End If
Case "予測業務"
If Not myDic(2).Exists(buf) Then
myDic(2).Add buf, Application.Index(tbl, j, 0)
End If
End Select
Next j
Next i
Worksheets("計算用シート見積り").Range("D4").Resize(myDic(1).Count, 4).Value = _
Application.Transpose(Application.Transpose(myDic(1).Items))
Worksheets("計算用シート予測").Range("D4").Resize(myDic(2).Count, 4).Value = _
Application.Transpose(Application.Transpose(myDic(2).Items))
End Sub
（ｍｏｍｏ）
momo様
試してみたらうまくいきました、大変助かりました。本当にありがとうございます！！ ちなみにJ:M P:S V:Y についてはすでに対応済みというのはFor i = 4 To 22 Step 6 のコードになるのでしょうか？ せっかく教えて頂いたので、これから活用できるようにコードを勉強します。
(sachi)
>ちなみにJ:M P:S V:Y についてはすでに対応済みというのはFor i = 4 To 22 Step 6 >のコードになるのでしょうか？
そのとおりです。 変数iの可変範囲をD列（Column(4)という事)からV列（22）まで６列おきに変化させて .Range(.Cells(4, i), .Cells(183, i + 3)).Value というコードでｉが１の時はD4:G183 ２の時はJ4:M183 ・・・ というように範囲指定して値を取得しています。
Dictionaryオブジェクト以外の部分は特に変わったコードではないので 普通にヘルプで理解を進められると思います。
中でも解らない事があればまた質問してください。 可能な範囲でお付き合いしますので、頑張ってください。 （ｍｏｍｏ）
momo様
わかりやすい説明ありがとうございました。 最初は？？？の状態でしたが、ちょっとずつわかってきました。
また疑問点がありましたら質問させてください、よろしくお願い致します。
(sachi)
momo様
すみませんが、この件でもう1点教えてください。 月によっては予測業務が発生しない可能性があるのですが、「計算用シート1」の区分（D,J,P,V列） に予測業務が無い場合、型が一致しませんというエラーが出ました。 このエラーを回避するためにはどうしたらいいのでしょうか？
(sachi)
>Worksheets("計算用シート見積り").Range("D4").Resize(myDic(1).Count, 4).Value = _
> Application.Transpose(Application.Transpose(myDic(1).Items))
>Worksheets("計算用シート予測").Range("D4").Resize(myDic(2).Count, 4).Value = _
> Application.Transpose(Application.Transpose(myDic(2).Items))
の部分を、myDicのCountが0以上の時に実行するようにIf分岐します。
If myDic(1).Count > 0 Then
Worksheets("計算用シート見積り").Range("D4").Resize(myDic(1).Count, 4).Value = _
Application.Transpose(Application.Transpose(myDic(1).Items))
End If
If myDic(2).Count > 0 Then
Worksheets("計算用シート予測").Range("D4").Resize(myDic(2).Count, 4).Value = _
Application.Transpose(Application.Transpose(myDic(2).Items))
End If
とする事で0個の場合に処理を飛ばす事ができます。 （ｍｏｍｏ）
momo様
教えて頂いたコードでエラーが消えました。ありがとうございました！
(sachi)
momo様
上記で計算用シート見積りと計算用シート予測に表示されたデータの並び替えしたいのですが、 下記のようなコードを追加してみたらエラーにはならないものの、並び替えがされません。 (マクロの新しい記録で試してみたコードを見よう見真似で修正してみたのですが・・・） コードをどのように直したらいいのでしょうか？ 各シートのD4:U56のデータをE列をキーに昇順で並び替えたいと思っています。 何度もすみませんが、教えてください。よろしくお願い致します。
Worksheets("計算用シート見積り").Select
Range("D4:U56").Sort Key1:=Range("E4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Worksheets("計算用シート追加").Select
Range("D4:U56").Sort Key1:=Range("E4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
(sachi)
ソートも範囲内に値が無いとエラーになると思いますので 前回のIf分の中にソートを置く感じで あとはSheetをSelectして実行するのではなくてSheetオブジェクトに対して実行できるように 少し修正します。 前回と同じ部分を以下のようにしてみてください。
If myDic(1).Count > 0 Then
With Worksheets("計算用シート見積り")
.Range("D4").Resize(myDic(1).Count, 4).Value = _
Application.Transpose(Application.Transpose(myDic(1).Items))
.Range("D3").CurrentRegion.Sort Key1:=.Range("E4"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End With
End If
If myDic(2).Count > 0 Then
With Worksheets("計算用シート予測")
.Range("D4").Resize(myDic(2).Count, 4).Value = _
Application.Transpose(Application.Transpose(myDic(2).Items))
.Range("D3").CurrentRegion.Sort Key1:=.Range("E4"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End With
End If
（ｍｏｍｏ）
momo様
教えて頂いたコードで試してみたところ、並び替えはできたのですが、見出しが入っていた 2行目、3行目まで並び替えられてしまいました。（A2からすべて対象範囲になっているようです。） D4:U56までのみを並び替えの対象とするにはどうしたらいいのでしょうか？ 何度もすみません。
(sachi)
そうでしたか、見出しは１行だけだと思っていたので。 では２ヶ所あるソートメソッドの
> .Range("D3").CurrentRegion.Sort Key1:=.Range("E4"), Order1:=xlAscending, Header:=xlYes, _
> OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
> SortMethod:=xlPinYin, DataOption1:=xlSortNormal
の部分を
.Range("D4:U56").Sort Key1:=.Range("E4"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
に変更してみてください （ｍｏｍｏ）
momo様
こちらの説明不足によるエラーだったようで、失礼致しました。 試したところ、「実行時エラー1004 アプリケーション定義または オブジェクト定義のエラー」 になったのですが、DataOption1:=xlSortNormalのところを消してみたらうまくいきました。 （昨夜は違うPCで試したので、このエラーは出ませんでした。） ご対応頂き、ありがとうございました。
(sachi)
過去の話ですみませんが、再度質問させて下さい 教えて頂いた上記のコードですが、「計算用シート1」シートのD:G列の重複の無いリストを 別シートにコピーしていたのが、1列分減って、D〜F列の重複のないリストをコピーしようと しています。 また対象人数が4人から10人に増えたため、そこも対応できるようにコードの下記の部分を 修正してみました。
(修正前）
For i = 4 To 22 Step 6 ’D列からV列まで6行おき
With Worksheets("計算用シート1")
tbl = .Range(.Cells(4, i), .Cells(183, i + 3)).Value 'ｉが１の時はD4:G183
(修正後）
For i = 4 To 49 Step 5 ’D列からAW列まで5行おき
With Worksheets("計算用シート1")
tbl = .Range(.Cells(4, i), .Cells(183, i + 2)).Value 'ｉが１の時はD4:F183
これでマクロを実行してみたところ、インデックスが有効範囲にないというエラーになりました。 コードの修正が間違っているのか、他の部分の修正が必要なのか、すみませんが教えて下さい。 よろしくお願いします。
(sachi)
すみません、自分で解決できました。 失礼致しました。
(sachi)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.