[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『生成されたシートにフィルターを最初から設置しておきたい。』（Lila）
いつもお世話になっております。
[[20151022153817]] 『別ブックを複数使用した部品交換率の表』（Lila）
こちらでβさんに頂いた以下のコード２つに、オートフィルターを設置するためのコード（Range("A4").AutoFilter）を追加したいのですが、何処に入れて良いのかが解りません･･･。
コード1の方はSheet2を生成しているこの箇所かなぁ･･･？とは思っているのですが･･･
【 Set shA = Workbooks("部品データベース.xlsm").Sheets("Sheet2") '商品別部品使用数（集約表）（★ブック名、シート名変更箇所）
Set shC = Workbooks("30-21 MTBF 機種別小分類.xlsx").Sheets("30-21 MTBF 機種別小分類") '稼働台数（★ブック名、シート名変更箇所）
Set dicA = CreateObject("Scripting.Dictionary")
Set dicC = CreateObject("Scripting.Dictionary")
For Each c In shC.Range("A2", shC.Range("A" & Rows.Count).End(xlUp))
k = Format(c.Value, "yyyymm") & normalize(c.Offset(, 1).Value) '年月+集約コード
dicC(k) = dicC(k) + c.Offset(, 2).Value '稼働台数
Next】
お手数ですが、ご教示ください。
よろしくお願い致します。
【コード1】
Function normalize(s As String) As String
normalize = WorksheetFunction.Clean(WorksheetFunction.Trim(s))
End Function
Sub 故障率2()
Dim shA As Worksheet
Dim shB As Worksheet
Dim shC As Worksheet
Dim c As Range
Dim dicA As Object
Dim dicC As Object
Dim k As Variant
Dim mCol As Long
Dim mRow As Long
Dim j As Long
Dim sv As String
Dim parts As String
Dim yyyymm As String
Dim n As Long
Dim Sp As Shape
Application.ScreenUpdating = False
Set shB = ThisWorkbook.Sheets("Sheet2")
shB.Cells.Clear
ThisWorkbook.Sheets("Sheet1").Cells.Copy shB.Range("A1") '故障部品データベース（★シート名変更箇所）
For Each Sp In shB.Shapes
Sp.Delete
Next
Set shA = Workbooks("部品データベース.xlsm").Sheets("Sheet2") '商品別部品使用数（集約表）（★ブック名、シート名変更箇所）
Set shC = Workbooks("30-21 MTBF 機種別小分類.xlsx").Sheets("30-21 MTBF 機種別小分類") '稼働台数（★ブック名、シート名変更箇所）
Set dicA = CreateObject("Scripting.Dictionary")
Set dicC = CreateObject("Scripting.Dictionary")
For Each c In shC.Range("A2", shC.Range("A" & Rows.Count).End(xlUp))
k = Format(c.Value, "yyyymm") & normalize(c.Offset(, 1).Value) '年月+集約コード
dicC(k) = dicC(k) + c.Offset(, 2).Value '稼働台数
Next
With shA.Range("A1", shA.UsedRange)
With .Offset(2, 1).Resize(.Rows.Count - 2, .Columns.Count - 1)
For Each c In .Cells
k = normalize(c.EntireRow.Cells(1).Value) & vbTab & normalize(c.EntireColumn.Cells(1).Value) '部品番号+集約コード
dicA(k) = dicA(k) + c.Value '集約コード内部品数
Next
End With
End With
With shB
With .UsedRange
mCol = .Columns.Count
mRow = .Rows.Count
End With
For j = mCol - 11 To 5 Step -12 '最終ブロックの先頭列からE列まで 12列単位で処理
sv = normalize(.Cells(1, j).Value) '集約コード
.Columns(j).Resize(, 6).Delete
.Cells(1, j).Value = sv
With .Range(.Cells(5, j), .Cells(mRow, j + 5))
For Each c In .Cells
parts = normalize(c.EntireRow.Cells(1).Value)
yyyymm = Format(c.EntireColumn.Cells(2).Value, "yyyymm")
n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv)
If n = 0 Then
c.Value = ""
Else
c.Value = c.Value / n
End If
Next
.NumberFormatLocal = "0.00%"
End With
Next
End With
MsgBox "処理が完了しました。"
End Sub
【コード2】
Sub 分割2()
Dim fSh As Worksheet
Dim tSh As Worksheet
Dim mCol As Long
Dim mRow As Long
Dim j As Long
Dim x As Long
Dim myCode As String
Dim grpCode As String
Dim grpList As Range
Dim f As Range
Dim dic As Object
Dim shn As Variant
Dim r As Range
Dim d As Range
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary") 'シート生成辞書
With Sheets("グループ").Range("A1").CurrentRegion
Set grpList = .Offset(, 1).Resize(, .Columns.Count - 1)
End With
Set fSh = Sheets("Sheet2") '元シート
With fSh.Range("A1", fSh.UsedRange)
mCol = .Columns.Count
mRow = .Rows.Count
End With
For j = 5 To mCol Step 6 '集約ブロックの先頭列を抽出
myCode = fSh.Cells(1, j).Value '集約コード
Set f = grpList.Find(What:=myCode, LookAt:=xlWhole)
If f Is Nothing Then
MsgBox myCode & " のグループ登録がないので処理をスキップします"
Else
If WorksheetFunction.CountA(fSh.Cells(3, j).Resize(mRow - 2, 6)) > 0 Then '★
grpCode = f.EntireRow.Cells(1).Value 'グループコード
If Not dic.exists(grpCode) Then
Application.DisplayAlerts = False
If IsObject(Evaluate("'" & grpCode & "'!A1")) Then Sheets(grpCode).Delete
Application.DisplayAlerts = True
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set tSh = ActiveSheet
tSh.Name = grpCode
fSh.Range("A1").Resize(mRow, Columns("P").Column).Copy
'セル幅コピー
tSh.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
tSh.Cells.Clear
fSh.Range("A1").Resize(mRow, 3).Copy tSh.Range("A1")
dic(grpCode) = True
Else
Set tSh = Sheets(grpCode)
End If
With tSh.Range("A1", tSh.UsedRange)
If .Columns.Count < 5 Then
x = 5
Else
x = .Columns.Count + 1
End If
End With
fSh.Cells(1, j).Resize(mRow, 6).Copy tSh.Cells(1, x)
End If '★
End If
Next
'空白行の削除
For Each shn In dic
With Sheets(shn).UsedRange
Set d = Nothing
For Each r In .Offset(4, 4).Resize(.Rows.Count - 4, .Columns.Count - 4).Rows
If WorksheetFunction.CountA(r) = 0 Then
If d Is Nothing Then
Set d = r
Else
Set d = Union(d, r)
End If
End If
Next
If Not d Is Nothing Then d.EntireRow.Delete
End With
Next
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
オートフィルターを設定するのは、どのブックのどのシートですか？
（β） 2015/12/28(月) 13:32
例によって忘却の彼方なんですが、オートフィルターを設定するシートの、その設定イメージもアップいただけるとありがたいです。
関連のシート、タイトル行が複数行のケースもありますよね。 でもオートフィルターは、あくまでタイトル行が１行ですので、具体的には、どこにどのような▼を設定したいのかな？
（β） 2015/12/28(月) 16:20
どのブックかというと、故障部品のリストなので、Bブックですね。
そこで故障率の計算がされて、「Sheet2」が生成される、というコードを頂いたのですが、その生成されたシート「Sheet2」にオートフィルター（無設定）を付けたいのです。
もうひとつは、その「Sheet2」からグループ分けを行ったそれぞれのシートにも同じく無設定のオートフィルターを付けておきたいなと思っています。
すでに年末年始休暇に入ってしまい、実データのレイアウトはとれないのですが、以前UPしたものを編集してみました。
下記のレイアウトの4行目が空白なのですが、そこにオートフィルターを設定したいです。
「Sheet2」の方は、E列からの6行づつデータが、Sheet1に登録した機種分ずらっと並んでいます。
グループ分けしたものは、今の所1〜4機種ぐらいづつで分かれています。
よろしくお願いします。
【レイアウト】
|[A] |[B] |[C] |[D]|[E] |[F] |[G] |[H] |[I] |[J] |
[1] |部品ｺｰﾄﾞ |品名 |英語品名 | | aaaaaa |
[2] | | | | | | | | | | |
[3] | | | | |2015/05|2015/06|2015/07|2015/08|2015/09|2015/10|
[4] | | | | | | | | | | |
[5] |MP-M015001|abcdeeeeessssa | | | 4.02%| 0.01%| 0.01%| 4.02%| 0.01%| 4.02%|
[6] |MP-M015372|sdfhrlaaaaaa | | | 0.01%| 0.01%| 0.01%| 0.02%| 0.01%| 0.01%|
[7] |MP-M603760|hsummmssann | | | 0.02%| 0.00%| 0.02%| 0.02%| 0.00%| 0.02%|
[8] |MP-M905240|mmmmkkkjkiuuuuu | | | 0.02%| 0.02%| 0.02%| 0.02%| 0.02%| 0.02%|
[9] |MP-1033477|lkuddsjoueeeeesa | | | 0.00%| 0.00%| 0.00%| 0.01%| 0.00%| 0.00%|
[10]|MP-E000019|amsdbauiddddfvn | | | 0.01%| 0.01%| 0.01%| 0.01%| 0.01%| 0.01%|
[11]|MP-E103961|dsuioeblvlsm,,,,,nn| | | 0.00%| 0.00%| 0.00%| 0.00%| 0.01%| 0.00%|
（Lila） 2015/12/29(火) 08:46
オートフィルター設定部分だけですが、サンプルです。 (アップ後、ちょこっと訂正）
Sub Sample()
With Sheets("Sheet2")
.AutoFilterMode = False '念のためにオートフィルター解除
.UsedRange.Offset(3).Resize(.UsedRange.Rows.Count - 3).AutoFilter
End With
End Sub
追記）12/29 13:11
↑で生真面目に（？）Resizeで領域行数も指定しましたが、よく考えれば、UsedRangeの下は空白ですので
.UsedRange.Offset(3).AutoFilter
でよかったです。
（β） 2015/12/29(火) 08:57
ありがとうございます！
業務開始したらまた検証させて頂きます^o^！
（Lila） 2015/12/31(木) 17:31
頂いたコードを実行してみましたら、ちゃんと動作していました！
ありがとうございます。
ですが、計算時に、マクロを登録したボタンを押下のみで、計算から新規生成シート（Sheet2）へのオートフィルター付与までを行いたいのですが、このコードを何処に挿入すれば良いのでしょうか？
故障率2の方で、＞MsgBox "処理が完了しました。" の前に挿入で大丈夫でしょうか？
また、分割の方ではシート名を指定するのではなく、「グループ」タブのA列に入った文字列を指定していく事は可能ですか？
よろしくお願い致します。
（Lila） 2016/01/06(水) 09:27
あけましておめでとうございます。
●故障率2
単一シート("Sheet2")で、かつ、そのシートは shB という変数で参照していますね。かつ、With shB とくくっています。
ですから、たとえば 最後の End With の直前に
.AutoFilterMode = False '念のためにオートフィルター解除 .UsedRange.Offset(3).AutoFilter
ここにいれてはいかがでしょうか。
●分割2
各シート名は Dic に格納されています。 で、最後の処理で、各シートの空白行を削除していますが、この処理ブロックは
With Sheets(shn).UsedRange ' ' ' End With
と、対象領域が With でくくられていますね。 ですから、End With の直前に
.Parent.AutoFilterMode = False '念のためにオートフィルター解除 .Offset(3).AutoFilter
こうしてはいかがでしょうか。
故障率2 と 分割2 は With でくくっているものが、一方はシート、一方は領域ですので コードもちょっと変えています。
（β） 2016/01/06(水) 10:21
二つとも、ばっちり動きました！
いつもいつも助けていただき、本当にありがとうございます！
また何かありましたら、よろしくお願いしますm(_ _)m
（Lila） 2016/01/06(水) 10:35
並び替えのVBAを調べて、以下のようなものを書いてみましたが、解らないことがあるので、ご教示ください。
.Parent.Sort.SortFields.Add _
Key:=Range("J5"), _
Order:=xlDescending
領域の指定は、βさんが先日のオートフィルターで教えてくださった「.Parent」にする事で恐らく出来たようですが、実行すると、オートフィルターの設定画面？というか、オートフィルターをクリックした状態になってしまい、自動で設定ができない（生成された全てのシートに有効になっていないような？？）状態になっています。
又、一番優先されるキーはJ列ですが、その後のI列からE列の指定は同じようにこの後ろにどんどん追加していけばいいのでしょうか？
よろしくお願いします＞＜。
（Lila） 2016/01/08(金) 09:37
オブジェクト参照をParentで戻したり、またその UsedRange としたりして、ちょっとわかりにくくなってしまいますが 以下で試してみてください。
With Sheets(shn).UsedRange
Set d = Nothing
For Each r In .Offset(4, 4).Resize(.Rows.Count - 4, .Columns.Count - 4).Rows
If WorksheetFunction.CountA(r) = 0 Then
If d Is Nothing Then
Set d = r
Else
Set d = Union(d, r)
End If
End If
Next
If Not d Is Nothing Then d.EntireRow.Delete
'並び替え
With .Parent
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("J5") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("I5") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("H5") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("G5") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("F5") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("E5") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange .Parent.UsedRange.Offset(3)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
.Parent.AutoFilterMode = False '念のためにオートフィルター解除
.Offset(3).AutoFilter
End With
（β） 2016/01/08(金) 13:50
Withを使用したコードなので、前回同様、End Withの前に挿入しました。
Parentだったり UsedRangeになったりで、まだ？？？の部分が多いですが、少しづつ何をしているのか見ていこうと思います。
本当にありがとうございます＞＜
（Lila） 2016/01/08(金) 14:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.