[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別ブックを複数使用した部品交換率の表』（Lila）
こんにちは、今回もよろしくご教示頂ければと思います。
[[20151015154911]] こちらの続き的なものになるのですが、
部品の交換率での異常を見る表を作成したいのです。
前回の完成品（グループごとにタブ分けされた、故障部品の数値）から前々回の完成品（商品１つに対する使用部品数一覧）と稼働台数の書いてあるそれぞれ3つのブックを使用して【 故障部品/使用数*稼働台数 】という計算をして、シートに部品コード、品名、英語品名と共に計算結果を記載したいです。
・【故障部品/使用数*稼働台数】はその月の数値が入った場所に対して計算します
・【故障部品/使用数*稼働台数】は最新月から遡って半年分計算します
それぞれの部品数は現在、一番多いものでも205行（データ行のみ。全部あわせてなら209行）です。
転記部分はVBA、計算部分は関数の方が良いのかなと思うのですが（データ部分に、この月はデータがあるけれど、次の月はデータがないという事があるため）、複雑な関数は良く判りません･･･
やはり、どちらかの方が、処理が軽くて早いでしょうか？
ご教示頂けると大変助かります。
よろしくお願いします。
（尚、当方算数数学がからっきしなので、途中の計算式も間違い等ありましたらすみません；）
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
前回のレイアウト、前々回のレイアウトといっても、それぞれに、いくつかのサマリー表もつくりましたし また、β以外の回答者さんたちにとっては、どんなレイアウトなのか皆目わかりませんね。
このレイアウトとこのレイアウトという具体例のサンプルを例のユーティリティを使ってアップすれば ほかの方々からのアドバイスも期待できますね。もちろん、私も考えてはみますが。
（β） 2015/10/22(木) 19:02
・グループごとにタブ分けレイアウトは、1種類（下記例のもの）～最大4種類まで、1種類それぞれ12列で記載されています。
・商品ひとつひとつに対する使用部品数一覧は「大項目＞中項目＞小項目＞形状」の4層に分かれており、それら全てを網羅するもの、中項目までしかないもの、小項目までしかないもの、大項目のみのものも含まれています。
＜グループごとにタブ分けレイアウト＞
|[A] |[B] |[C] |[D]|[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |
[1] |部品ｺｰﾄﾞ |品名 |英語品名 | | aaaaaa |
[2] | | | | | | | | | | | | | | | | |
[3] | | | | |2014/11|2014/12|2015/01|2015/02|2015/03|2015/04|2015/05|2015/06|2015/07|2015/08|2015/09|2015/10|
[4] | | | | | | | | | | | | | | | | |
[5] |MP-M015001|abcdeeeeessssa | | | 4| 1| 1| 4| 1| 4| 8| 8| 8| 8| 8| 8|
[6] |MP-M015372|sdfhrlaaaaaa | | | 1| 1| 1| 2| 1| 1| 2| 1| 1| 1| 2| 2|
[7] |MP-M603760|hsummmssann | | | 2| | 2| 2| | 2| 2| 2| 2| 2| 2| 2|
[8] |MP-M905240|mmmmkkkjkiuuuuu | | | 2| 2| 2| 2| 2| 2| 2| 2| 2| 2| 2| 2|
[9] |MP-1033477|lkuddsjoueeeeesa | | | | | | 1| | | 1| 8| 9| | | 1|
[10]|MP-E000019|amsdbauiddddfvn | | | 1| 1| 1| 1| 1| 1| 1| 1| 1| 1| 1| 1|
[11]|MP-E103961|dsuioeblvlsm,,,,,nn| | | | | | | 1| | | | | | | 1|
稼働台数のレイアウトはまだ取っていないので、取得次第編集させて頂きます。
（Lila） 2015/10/23(金) 08:40 使用レイアウト変更のため削除
商品ひとつひとつに対する使用部品数一覧 ですけど、このレイアウトを相手にするより、 [[20151015154911]] 『月ごとの使用数を転記したい。』（Lila） の、（β） 2015/10/19(月) 16:36 で提示した、大項目・中項目で集約したものを使ったほうが 処理しやすいと思いますが？
（β） 2015/10/23(金) 09:22
＜稼働台数レイアウト＞
|[A] |[B] |[C]
[1]|設定月 |集計区分 |稼働台数
[2]|2015/10/01|aaaaa | 11
[3]|2015/10/01|ddsddd | 58
[4]|2015/10/01|ccsdd | 46
[5]|2015/10/01|bbbbbbb | 133
[6]|2015/10/01|abcde | 19
＜商品ひとつひとつに対する使用部品数一覧レイアウト＞
|[A] |[B] |[C] |[D] |[E] |[F]
[1]| |Ebddd|TTTaa|cdxxx |aaaaa|bbbbb
[2]| | | | | |
[3]|MP-*EMC-13HK-3D| | | | |
[4]|MP-*IP085C-SDM5| | | | |
[5]|MP-*M201400 | | | | |
[6]|MP-00021182 | | | | |
[7]|MP-00021205 | | | | |
[8]|MP-00030687 | | | | |
[9]|MP-00880152 | | | | 8| 8
＜結果イメージレイアウト＞
|[A] |[B] |[C] |[D]|[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |
[1] |部品ｺｰﾄﾞ |品名 |英語品名 | | aaaaaa |
[2] | | | | | | | | | | | | | | | | |
[3] | | | | |2014/11|2014/12|2015/01|2015/02|2015/03|2015/04|2015/05|2015/06|2015/07|2015/08|2015/09|2015/10|
[4] | | | | | | | | | | | | | | | | |
[5] |MP-M015001|abcdeeeeessssa | | | 4| 1| 1| 4| 1| 4| 8| 8| 8| 8| 8| 8|
[6] |MP-M015372|sdfhrlaaaaaa | | | 1| 1| 1| 2| 1| 1| 2| 1| 1| 1| 2| 2|
[7] |MP-M603760|hsummmssann | | | 2| | 2| 2| | 2| 2| 2| 2| 2| 2| 2|
[8] |MP-M905240|mmmmkkkjkiuuuuu | | | 2| 2| 2| 2| 2| 2| 2| 2| 2| 2| 2| 2|
[9] |MP-1033477|lkuddsjoueeeeesa | | | | | | 1| | | 1| 8| 9| | | 1|
[10]|MP-E000019|amsdbauiddddfvn | | | 1| 1| 1| 1| 1| 1| 1| 1| 1| 1| 1| 1|
[11]|MP-E103961|dsuioeblvlsm,,,,,nn| | | | | | | 1| | | | | | | 1|
（Lila） 2015/10/23(金) 09:33 使用レイアウト変更後のものを追加 10：41
３つのブック（シート）が登場するので、仮に
商品ごとの使用部品数一覧（これは、再掲された集約版） をAブック（Aシート） 故障部品数リスト をBブック（Bシート） 稼働台数表を Cブック（Cシート）
としてコメントします。
いくつか確認。
１．Bブックですが、直近１２か月がすでに記載されているのですね？ なので、12列の中の後半の６列に対して分析を行うということでいいのですか？ ２．Cブック。１つの集計区分で同じ月のものが複数登場することはないですね？ ３．計算結果は 故障数/使用総数 ですから 割合ですよね。つまり % で表示するのですね？ ４．で、これた３つから作り出される表のレイアウトって、自由に考えていいのですか？ ５．また、今回の処理、３つのブックのうち、いずれが、マクロブックになりますか？
（β） 2015/10/23(金) 13:44
はい。そうです。
前回（[[20151015154911]] ）のタブ分けされた７つのシートを元としての方が組みやすいのか、それとも分ける前の1つのシートに纏まっている方が組みやすいのがでまたコードも変わると思いますが、どちらの場合でも「数値、直近12ヶ月の年月」は入力されている状態ではあります。
＞ ２．Cブック。１つの集計区分で同じ月のものが複数登場することはないですね？
これは、あります。
なぜかと言うと、同じもの例えば「aaaaa」には「aaa-300」「aaa-500」「aaa-1800」等という型は同じだけど、大きさや幅などが違うシリーズものが含まれている為です。
ただ、もう古過ぎたり、海外専用などのものが多数なので、そこは複数あっても大丈夫（表に記載する予定がないので）なのかなと。
（もちろん、データを記載しなければいけない場合も出てくるかもしれませんが･･･）
＞ ３．計算結果は 故障数/使用総数 ですから 割合ですよね。つまり % で表示するのですね？
そうですね。
最終的には「％」を入れて表示する予定です。
＞ ４．で、これた３つから作り出される表のレイアウトって、自由に考えていいのですか？
えと、イメージは上記に載せたのですが、「A」「B」「C」列が「部品コード」「品名」「英語品名」になっており、どの商品の直近12ヶ月の部品故障率はこう！
というのがわかる様になれば、問題ありません。
＞ ５．また、今回の処理、３つのブックのうち、いずれが、マクロブックになりますか？
今回の処理は「Bブック」をマクロブックにしようと考えています。
（Lila） 2015/10/23(金) 14:22
>>タブ分けされた７つのシートを元としての方が組みやすいのか、それとも分ける前の1つのシートに纏まっている方が組みやすいのが
あぁ、そうですね。分ける前のほうがシートのループがなくなるので、素直なコードになるでしょうね。
>>集計区分で同じ月のものが複数登場 <-- これはあります。
了解です。合計します。
>>レイアウト
掲示されたのは１２か月が掲載。要件説明では ６か月とあったので？
>>「Bブック」をマクロブック
了解です。
（β） 2015/10/23(金) 14:34
先日頂いたコードをシート名などを変更すれば、そこからグループ分けが可能になりますかね？
＞ >>レイアウト
＞ 掲示されたのは１２か月が掲載。要件説明では ６か月とあったので？
ああ･･･すいません。確かにそうですね；
6ヶ月で大丈夫です。
レイアウトも、12列の半分の6列になります！
（Lila） 2015/10/23(金) 15:13
かなり手抜きというか決め打ちのコードです。 かつ、稼働確認（動くということ）はしましたが結果の検証は全くしていないのでよろしくお願いします。
関連のブックをマクロ内で開いて参照して閉じるということも、もちろんできますが、とりあえずは 実行時に マクロブック（故障部品数ブック Bブック)のほかに、商品別部品使用数ブック（Aブック）、稼働台数ブック（Cブック）は 開かれているというところからのコードになっています。
またAブックは集約版のシートを使います。またマクロブック（Bブック）は、グループコード別分解シートではなく、元のすべてが入ったシートをあいてにします。 Bブックの各集約コード別列数は12列と決め打ちしています。（マクロで列数を自動把握もできますが、していません） かつ、このシートを新規ブックとしてコピーして、それに対して処理を行います。 処理後も、保存せず、とりあえず、そのまま新規ブックとしてエクセル上に残っています。
ブック名、シート名等は コードの先頭のほうで規定していますので実際のものに直してください。
Sub 故障率()
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
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Sheet1").Copy '故障部品
Set shB = ActiveWorkbook.Sheets(1)
Set shA = Workbooks("Aブック.xlsm").Sheets("Sheet2") '商品別部品使用数（集約表）
Set shC = Workbooks("Cブック.xlsx").Sheets("Sheet1") '稼働台数
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") & 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 = c.EntireRow.Cells(1).Value & vbTab & 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 = .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 = c.EntireRow.Cells(1).Value
yyyymm = Format(c.EntireColumn.Cells(3).Value, "yyyymm")
n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv)
If n = 0 Then
c.Value = "#DIV/0!"
Else
c.Value = c.Value / n
End If
Next
.NumberFormatLocal = "0.00%"
End With
Next
End With
End Sub
（β） 2015/10/23(金) 22:11
＞[[20151015154911]] 『月ごとの使用数を転記したい。』（Lila）
＞ の、（β） 2015/10/19(月) 16:36 で提示した、大項目・中項目で集約したものを使ったほうが
こちらの集約コードなのですが、頂いたときに動作確認し、シート2に結果も出たのですが、今↑のコードの検証前に、データを新しくしようとマクロを走らせたら、コード下のほうの
＞vntT(y, x) = vntT(y, x) + c.Value '集約表配列に足し込み
で「エラー13 型が一致しません」が発生してしまい、宣言のところで他の型にしてみると、今度は「コンパイルエラー 配列がありません」で
＞ReDim vntT(1 To nRows, 1 To dicX.Count) '集計表領域サイズの配列
ここの
＞ReDim vntT(1 To nRows, 1 To
この部分が青くなってしまいました。
型は元は「Variant」になっていて、「Long」「String」「Range」「Object」を試してみましたが、どれも配列がありませんのコンパイルエラーになってしまいます。
大項目～形状の箇所を少しいじった（列削除や挿入、入力）くらいしか、以前の検証時と変わりは無いのですが･･･
（Lila） 2015/10/26(月) 09:24
こんにちは。
不思議ですね。 Lilaさん案件のもろもろのブック、こちらで、同じフォルダに入れてあるのですが、要件変更にあたって 少しずつコードを変えたりしていて、マクロブックのバージョンが異なるものが、いくつもあって どれが、最新か、自分自身でも迷ったりしていますが、きっと、このコードが最新だろうというもので AブックのSHeet1,SHeet2ができている状態から、使用量集計を走らせても、問題なく Sheet2が再作成されます。
vntT(y, x) = vntT(y, x) + c.Value '集約表配列に足し込み
ここでエラーになった時点で、マウスを vntT(y, x) や c.Value の上に充てると、どんな値がポップアップされますか？
もし、c.Value が数値ではなかったら、
・Ctrl/g で イミディエイトウインドウを表示させ、そこに ?c.Address とタイプしてエンター。 そこに出てくるセルアドレスの場所がどうなっているか、確かめてもらえますか？
★今、久しぶりの風邪でダウン中。対応が遅れるかもしれませんがご容赦ください。
（β） 2015/10/26(月) 12:31
＞c.Value
こちらは 「=4」の値でした。
こちらは、Sheet2を作成した状態（何も入力されていない状態）でマクロを走らせました。
＞ ・Ctrl/g で イミディエイトウインドウを表示させ、そこに ?c.Address とタイプしてエンター。
＞ そこに出てくるセルアドレスの場所がどうなっているか、確かめてもらえますか？
こちら、一応数値ではありましたが念のため確認して「$X$275」と出ましたので、そのセル値を確認しました所、「4」だったので問題はなさそうに見えますが･･･
丁度この「W」「X」「Y」列で変更作業をしたので、その影響？とも･･･
（変更前は「W～Y」の1行目2行目がそれぞれ結合セルでしたが、よくよく数値を持ってくるデータシートを見ましたら、「W」列と「X」列で1シート、「Y」列で1シートになっていた為、同じ英数字を「大項目～中項目」で使用していますが、別列に分けました。）
＞ ★今、久しぶりの風邪でダウン中。対応が遅れるかもしれませんがご容赦ください。
風邪つらいですね＞＜
暖かくして水分を摂りゆっくり寝てください！
今年の風邪は、咳が残る風邪のようですので、のど飴も忘れずに･･･＞＜
お大事にしてくださいね･･･！
（Lila） 2015/10/26(月) 13:07
>>＞vntT(y, x) >>ここには、数値で "3 6" の値が入っていました。
x や y ではなく、マウスを vntT にあてて、vntT(t,x) そのものの値を見ていただけますか？ 想像ですけど、数値ではないものが入っているのでは？
で、なぜ数値ではないものが入ったか。 気力が回復したら、ここについても説明しますが、今は、ちょっとサボらせてください。
いずれにしても、いま、集約しようとしている、vntT(y,x) に相当するデータの空白以外の最初のデータが 数値ではなく、何か変なものが入っているということだろうと思います。
SHeet1 の F1から、このリストの一番右下のセルまで選択して ホームタブ、右のほうの検索と選択、条件を選択してジャンプ ここで定数 を選び、数値のチェックをはずしてＯＫをおすと 何か選択されませんか？（シートのセルが正しい内容であれば、ここでは何も選択されないはずです）
（β） 2015/10/26(月) 16:57
vntT(y,x) = "3 6"
が入っています。
「y」と「x」にはまた別の数値が入っているようです。（y = 271 , x = 7）
＞ で、なぜ数値ではないものが入ったか。
＞ 気力が回復したら、ここについても説明しますが、今は、ちょっとサボらせてください。
はい、お元気になってからで構いませんので、解説よろしくお願いします＞＜
＞ SHeet1 の F1から、このリストの一番右下のセルまで選択して
＞ ホームタブ、右のほうの検索と選択、条件を選択してジャンプ ここで定数 を選び、数値のチェックをはずしてＯＫをおすと
＞ 何か選択されませんか？（シートのセルが正しい内容であれば、ここでは何も選択されないはずです）
F1～BF4までの大項目～形状の数値ではない部分と、データ部分の文字列のものに（例えば「2ｍ」等の）が選択されている状態になりました。
（Lila） 2015/10/26(月) 17:10
ぼぉっとしてましたね。 F1 からではなく F5 から、つまり 数値データが 入っているところの領域を選択して やってみてください。
今回のもの、 "3 6" 、これが犯人ですが、それ以外にもあるかもしれません。 それらを正しい値に打ち直してリトライ願います。
ところで、データ部分の文字列のものに（例えば「2ｍ」等の）・・・ これが気になっています。コードは、この領域は 数値ないしは空白だと考えています。 "3 6" でも、だめですが、"2ｍ" でも だめです。
ただ、各人の長年の習慣で、もう 2ｍ は、だめとはいえないということなら、手はあります。 でも、この集約表作成だけではなく、今までの他の機能にもすべて、その手をいれなければ不統一になりますねぇ。 で、2ｍ 等は救えたとしても "3 6" は救えないですね。（これは、3 扱いになります）
（β） 2015/10/26(月) 17:27
今回の障害の原因（と思われる）に関する参考コードです。
Sub ExcelVBAの小さな親切大きなお世話()
Dim n As Variant
n = n + "3 6" '<==犯人はここなのに
'
'
' 様々な処理
'
'
n = n + 4 '事件が発覚した時点では犯人は逃亡済み
End Sub
（β） 2015/10/26(月) 17:44
取り込むデータシートを見ているとたまに "3 6"こういったものがあり、これは前はこっちの数値を使用していたけれどいまはこっちという風に片方は取り消し線で消されていたりするものの修正見落としですね…すみません。
「2m」やその他文字列（ "3 6"こういうものは、私が元データをコツコツ直すしかありませんが）は処理せずに飛ばす（恐らく今回必要な故障部品というものには含まれないものばかりなので。セロテープ的なものや、チューブなどの消耗品に含まれるものかと）というコードにしてみようと思います。
確か以前頂いたコードにそのような処理があったと思うので！
（Lila） 2015/10/26(月) 18:31
>>私が元データをコツコツ直すしかありませんが
"3 6" 含めて、文字列を読み飛ばすことはできます。 できますが、そうしないほうがいいと思います。 入力した人は、「正しく」２ｍ や 3 6 と入れたつもり。 これを コードで スキップすると、結果として正しくない集計結果が作られ、しかもだれも気付かない。 この集計結果で何かを判断して、次の工程にいかしていくのでしょうから、それは具合わるいと思います。
といって こつこつ も大変でしょうね。
そもそもが、大本は、前回の結果ブックを作成するときに参照しているデータブックですよね。 ですから、データ取り込み の最初のほうで、領域 r1,r2,r3 に対してエラー値の存在有無をチェックしているところがありますが このあたりで、r3(データ領域) に対して、数式または定数で、論理値+文字列 があるかどうか、あれば スキップ というロジックを追加して、大本をたっておくということが必要だと思います。
で、その際に、どのセルが悪かったのかを表示するということもできるかと思いますので。
（β） 2015/10/27(火) 15:06
「2ｍ」などの文字列として入力されているのものは、消耗品なので、その場合は交換しても「故障」の方では上がってこない部分なので、まとめ用のSheet1にさえあれば問題ないかなと思っています。
一番最初に頂いたデータシートから結果シートへ転記する、というコードでは、確か「文字列でも数値でも関係なく転記する」という説明を頂いたかと思います。
＞ そもそもが、大本は、前回の結果ブックを作成するときに参照しているデータブックですよね。
＞ ですから、データ取り込み の最初のほうで、領域 r1,r2,r3 に対してエラー値の存在有無をチェックしているところがありますが
＞ このあたりで、r3(データ領域) に対して、数式または定数で、論理値+文字列 があるかどうか、あれば
＞ スキップ というロジックを追加して、大本をたっておくということが必要だと思います。
これは、そもそも「3 6」や「2ｍ」等の文字列になってしまっている物は転記しない、という命令という事ですか？
それとも「3 6」なら「3」、「2ｍ」なら「2」だけを転記するという命令ですか？
（Lila） 2015/10/27(火) 15:45
これから、故障部品のコード検証をして行きますので、そちらの結果報告は、後ほどさせて頂きます。
（Lila） 2015/10/27(火) 16:25
＞ n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv)
ここで、型が不一致のエラーがでたのですが、入っていた値が「0.25ｍ」だったので･･･
（Lila） 2015/10/27(火) 16:35
>>不思議なことに「2ｍ」や「0.0058ｍ」などは振り分けられていました
これは、「たまたま」です。「たまたま」の状況であれば "3 6" も振り分けができます。 もともと、この "3 6" は、前回の結果シートに、元データブックから取り込んだものですよね。 その時は、エラーになっていなかったわけです。
（β） 2015/10/26(月) 17:44 で、参考コードをアップしていますが、n = n + "3 6" ではエラーになりませんよね。 つまり、Variant型変数（セルも、同じなんですが）に "3 6" を【加算】できた？？
参考コードのプロシジャ名にかいた【小さな親切おおきなおせわ】が、ここで働きます。
もう１つ、参考コード。
Sub test1()
MsgBox "ABC" + "XYZ"
End Sub
Sub test2()
MsgBox "ABC" + 10
End Sub
Sub test3()
MsgBox 10 + "XYZ"
End Sub
Sub test4()
MsgBox 10 + 10
End Sub
この【加算】、エラーにはなるものと、ならないものがありますね。
+ という演算子、ふつうは 加算だと認識しますが、エクセルにとっては 「加算」ないしは【連結】です。 で、+ される側、ないしは+する側が 数値の場合に 加算、そうでなければ連結（ & ですね）されます。 ですから、当該マス目への最初のデータは、文字列であれ数値であれ、格納され、同じマス目に対して次のデータが あった場合に、マス目の値、ないしは加算しようとしている値によってエラーが発生したりしなかったりするわけです。
★基本的には、今回のコードに手を入れるのではなく
１）前回の結果シートに取り込んだ後、「コツコツ」と、修正。 ２）前回のコードで、このチェックを行い、おかしなところがあれば、そのおかしなセルがどこかを表示した上で取り込みスキップ。
いずれかでしょうね。 （β） 2015/10/27(火) 17:24
なるほど…ひっかかってしまう時もあれば、通ってしまう時もあるわけですね。
今回はすんなりできたけれど、また次回振り分けてみたらエラーになると言う事も十分に考えられる事ですね。
＞ １）前回の結果シートに取り込んだ後、「コツコツ」と、修正。
＞ ２）前回のコードで、このチェックを行い、おかしなところがあれば、そのおかしなセルがどこかを表示した上で取り込みスキップ。
そうですね。
暫くは、データをコツコツ修正していく事にします＞＜
（Lila） 2015/10/27(火) 18:26
コツコツも大変かもしれません。 ロジックとしては、前回の結果シート作成の一部分を抜き出したものですが、たとえば新規ブックで 以下のようなコードを書いたマクロブックを用意しておきます。 チェックファイル（選択画面で対象ファイルを１つまたは複数選択）あるいはチェックフォルダ（指定フォルダ内のすべてのブックを対象）を実行。
おかしなセルをこのマクロブックの最初のシートのＡ列に列挙します。
Sub チェックファイル()
Dim sel As Variant
Dim f As Variant
Dim wb As Workbook
Application.ScreenUpdating = False
sel = Application.GetOpenFilename("ExcelBook,*.xlsx", Title:="対象ファイルを選んでください", MultiSelect:=True)
If Not IsArray(sel) Then Exit Sub 'キャンセルボタン
ThisWorkbook.Sheets(1).Columns("A").ClearContents
For Each f In sel
Set wb = Workbooks.Open(f)
データチェック wb.Sheets("Sheet1") '★
wb.Close False
Next
Application.ScreenUpdating = True
MsgBox "処理が終了しました"
End Sub
Sub チェックフォルダ()
Dim fName As String
Dim wb As Workbook
Dim fPath As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
If Not .Show Then Exit Sub 'キャンセルボタン
ThisWorkbook.Sheets(1).Columns("A").ClearContents
fPath = .SelectedItems(1)
fName = Dir(fPath & "\*.xlsx")
Do While fName <> ""
Set wb = Workbooks.Open(fPath & "\" & fName)
データチェック wb.Sheets("Sheet1") '★
wb.Close False
fName = Dir()
Loop
End With
Application.ScreenUpdating = True
MsgBox "処理が終了しました"
End Sub
Sub データチェック(shF As Worksheet)
'=============================
Dim comRow As Long
Dim catRow As Long
Dim comCol As Long
Dim catCol As Long
'=============================
Dim w As Variant
Dim x As Long
Dim c As Range
Dim a As Variant
Dim f As Range
Dim ok As Boolean
Dim tmp As Long
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim ck1 As Range
Dim ck2 As Range
Dim ck3 As Range
Dim ck4 As Range
Dim shT As Worksheet
Dim mxCol As Long
Dim mxRow As Long
Dim nCols As Long
Dim nRows As Long
'=================================='データシートレイアウト規定 開始
'品番列
Set f = shF.Cells.Find(What:="品番", LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not f Is Nothing Then
comCol = f.Column
tmp = f.Row
'数量(項目)列
Set f = shF.Cells.Find(What:="数量", LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not f Is Nothing Then
If f.Row = tmp Then
catCol = f.Column
catRow = f.Row + 1
ok = True
End If
End If
End If
If Not ok Then
MsgBox shF.Parent.Name & " のシートに、品番もしくは数量がないか、または同じ行ではないのでチェックをスキップします"
Exit Sub
End If
mxRow = shF.Cells(Rows.Count, comCol).End(xlUp).Row 'データシートの品番列最終行番号
'品番開始行
comRow = shF.Cells(mxRow, comCol).End(xlUp).Row
'=================================='データシートレイアウト規定 終了
nRows = mxRow - comRow + 1 'データシートの品番数
mxCol = shF.Cells(catRow, Columns.Count).End(xlToLeft).Column 'データシートの項目のデータ最終列を求める
mxCol = mxCol + shF.Cells(catRow, mxCol).MergeArea.Columns.Count - 1 'そのセルの結合セルの列数を加味して､表の最終列を求める
nCols = mxCol - Columns(catCol).Column + 1 '表の列数
nRows = mxRow - comRow + 1 'データシートの品番数
Set r1 = shF.Cells(comRow, comCol).Resize(nRows) '品番領域
Set r2 = shF.Cells(catRow, catCol).Resize(4, nCols) '項目領域
Set r3 = shF.Cells(comRow, catCol).Resize(nRows, nCols) 'データ領域
On Error Resume Next
Set ck1 = Union(r1, r2).SpecialCells(xlCellTypeFormulas, xlErrors) '数式によるエラー値
Set ck2 = Union(r1, r2).SpecialCells(xlCellTypeConstants, xlErrors) '定数によるエラー値
Set ck3 = r3.SpecialCells(xlCellTypeFormulas, xlErrors + xlLogical + xlTextValues) '数式による数値以外
Set ck4 = r3.SpecialCells(xlCellTypeConstants, xlErrors + xlLogical + xlTextValues) '定数による数値以外
On Error GoTo 0
For Each a In Array(ck1, ck2, ck3, ck4)
If Not a Is Nothing Then
For Each c In a
If IsArray(w) Then
ReDim Preserve w(1 To UBound(w) + 1)
Else
ReDim w(1 To 1)
End If
w(UBound(w)) = c.Address(External:=True)
Next
End If
Next
If IsArray(w) Then
With ThisWorkbook.Sheets(1)
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(w)).Value = WorksheetFunction.Transpose(w)
End With
End If
End Sub
（β） 2015/10/27(火) 19:09
修正後のチェックにも使えそうです。
ありがとうございます！
とりあえず、修正頑張ります＞＜
（Lila） 2015/10/28(水) 08:45
今回の処理は Bシートを元にして、そこにある数値と、それに紐付く、Aシート、Cシートから導き出される部品総数から故障率を算出するものですので BシートのキーとAシート、Cシートから計算される総数のキーがマッチしなければ、分母がないわけですので、コード内で "#DIV/0!"をセットしています。
ここまでくれば、あとは、早い というか、いやいや、やっかいというか・・・・ なぜキーがマッチしないかという、今までもあった、これはやっかいな課題ですね。
もちろん、コードのバグということもありうるわけですが、（Lila） 2015/10/27(火) 16:25 では、いっったん集約できたわけですよね。 ということは、そのときのデータ（シート）と、データを修正して実行した、そのデータ（シート）との違いがどこかにある。 それを探ってもらえませんか。
各シートのキーとなるセルの値、これが、（今までもあったと思いますが）スペースがあったり、日付型ではなく文字列になっていたり 大文字小文字や全角半角・・・・
ちなみにキーとして扱っているのは
Bシート A列の部品番号、3行目の日付 に対して Aシート A列の部品番号、1行目の集約コード および Cシート A列の日付、B列の集計区分
ですから、そのあたりのセルをチェックしてみてください。
コード面からアプローチするとすれば、
With shB と n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv) にブレークポイントを設定し With shB で止まった時に ローカルウィンドウを表示して dicA と dicC の + をクリックして、その中のキーを表示させ n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv) で止まった時に parts や sv や yyyymm にマウスを当てて値を確認、 その値で連結されたキーの文字列が dicAやdicCの中身としてあるのかないのか、ないとしたらなぜなのか、
そういった調査をしてもらうしかないですねぇ。
（β） 2015/10/28(水) 10:52
昨日夕刻の時と、今日の集約データの違いは「文字列」が無くなった事ですかね･･･。
部品コード～英品名はAブック、Bブック共に同じ元データから引っ張ってきているので、ここは同一と考えて良いでしょう。
フィルターで見てみると、スペースが入っているセルがある場合チェック欄の隣が空白で何も書かれていないものがあり、それで解るのですが（使用数取り込みのデータにそういうものがありましたので、もちろん削除しました）、それも見当たらないようです。
＞ With shB と n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv) にブレークポイントを設定し
＞ With shB で止まった時に ローカルウィンドウを表示して dicA と dicC の + をクリックして、その中のキーを表示させ
すみません；ローカルウィンドウ･･･とは･･･何でしょうか･･･？
とりあえず「With shB」で停止させた時に入っていた値は
「dicA(k) = 0」（このとき、ｋにはA列最終行とAI1の値でした）
「dicC(k) = Empty 値（このときもｋには上記と同じものでした）
＞ n = dicA(parts & vbTab & sv) * dicC(yyyymm & sv) で止まった時に parts や sv や yyyymm にマウスを当てて値を確認、
＞ その値で連結されたキーの文字列が dicAやdicCの中身としてあるのかないのか、ないとしたらなぜなのか、
「parts」 と 「sv」にはそれぞれ、部品コードと商品名が入っていましたが、「yyyymm」は「 "" 」となり空白でした。
このあたりに問題がありそうな気がしますね。
とりあえず、日付セルをチェックしてみます。
（Lila） 2015/10/28(水) 11:40
>>とりあえず、日付セルをチェックしてみます。
お願いします。
>>ローカルウィンドウ･･･とは･･･何でしょうか･･･？
変数の上にマウスをあてると値がポップアップされるわけですが、ＶＢＥ画面の表示メニューで ローカルウィンドウ を選択すると、その時の変数が一覧ででてきますので、あれはどうなっている、これは、どうなっているという調査が やりやすくなっています。 で、配列やDIctinaryなんかは、+表示されていて、その +をクリックすると、その中身が表示されますので 是非活用してください。
（β） 2015/10/28(水) 13:47
>>「parts」 と 「sv」にはそれぞれ、部品コードと商品名が入っていましたが、「yyyymm」は「 "" 」となり空白でした。
これはおかしいですね。 この yyyymm は、今から扱おうとしている、Bシート（元のBシートをコピーした新規ブックのBシート）上の数値セルの列の３行目にある日付です。 これが空白ということは、基本的にはあってはいけないことですからね。
（β） 2015/10/28(水) 13:54
特にこれと言ってセルに問題は無い気もしますが･･･
Bブックはセル表示こそ「yyyy/mm」ですが実際は「yyyy/mm/dd」でCブックと相違があるわけではないですし･･･
コードで「yyyymm」として実際は表示が「yyyymm」なだけで「yyyymmdd」だった場合、何か問題がありますでしょうか？
＞ 変数の上にマウスをあてると値がポップアップされるわけですが、ＶＢＥ画面の表示メニューで
＞ ローカルウィンドウ を選択すると、その時の変数が一覧ででてきますので、あれはどうなっている、これは、どうなっているという調査が
＞ やりやすくなっています。
＞ で、配列やDIctinaryなんかは、+表示されていて、その +をクリックすると、その中身が表示されますので
＞ 是非活用してください。
なるほど。
そんな機能もあるのですね！
確かにたくさん入っているのを確認しました。
「dicA」に入っていたコードはありましたが、入っている商品名と続くものはありませんでした。
（Bブックにはあっても、Aブックにない商品でした）
「dicC」に日付+商品名はありました。
＞「With shB」で停止させた時
に出てくる新規ブックには、ちゃんと数値がコピー（？）されていました。
（Lila） 2015/10/28(水) 14:14
セルのチェックをしていただき、どこかおかしなセルを発見いただければいいのですが、最後の手段（？）として。
ｍｏｍｏさんのユーティリティで、実際のレイアウトをアップする手法はすでに使ってもらっていますが これでは、そのセルの中身が実際にどうなっているのかがみえません。
以下に紹介するのは、「学校」内で、半平太さんが掲載された、これまたすぐれもののユーティリティで 実際に、そのシートを復元するマクロを自動生成します。
・新規ブックに、以下に紹介するコード（とても長いです）を貼り付けて、調査用マクロブックとしておきます。 ・調査したいブックを開き、調査したいシートを選択して、そのシートのデータ領域をマウスで選択します。 （A1:AN100 とか） ・この状態で、レイアウトとサンプルデータ再現マクロ作成 を実行します。 ・マクロブックの 出力Wshというシート（なければ自動生成されます）にマクロコードが書きこまれます。 ・この書きこまれたコードを掲示板にアップいただくと、そちらで実際に使っておられるシートと同じ内容を持ったシートを こちらで作り出して検証することが可能になります。 ・今回の場合、Aシート、Bシート、Cシートで、実行して、それぞれでできあがる３つのこー＾度をアップしてもらえれば 助かります。
以下コードです（長いですががまんしてください）
Public Sub レイアウトとサンプルデータ再現マクロ作成()
Const modelMRG As String = " Range(""Adrs"").Merge"
Const modelCLR As String = " Range(""Adrs"").Interior.ColorIndex = "
Const modelVAL2 As String = " Range(""Adrs"").Value = "
Const modelFML As String = " Range(""Adrs"").FormulaR1C1Local = "
Const modelFMT As String = " Range(""Adrs"").NumberFormatLocal = ""@""" '文字列(頭が「’」のデータ処理
Const modelFME As String = " Range(""Adrs"").NumberFormatLocal = " '標準外の表示形式
Dim WSF As WorksheetFunction
Dim rslt
Dim dataToFil
Dim cel As Range
Dim Codes As String
Dim NN As Long, PP As Long
Dim BlocksToRight As Long, BlocksToBottom
Dim rngSelected As Range
Set rngSelected = Intersect(Selection, Selection.Parent.UsedRange)
If rngSelected.Rows.Count > 2000 Or _
rngSelected.Columns.Count > 100 Then
MsgBox "範囲が広すぎます"
Exit Sub
End If
Set WSF = WorksheetFunction
On Error Resume Next
ThisWorkbook.Sheets("出力Wsh").Range("A1").Value = Empty 'シート存在テスト
If Err.Number <> 0 Then
ThisWorkbook.Sheets.Add.Name = "出力Wsh"
End If
On Error GoTo 0
NN = 0
With ThisWorkbook.Sheets("出力Wsh")
NN = NN + 1: .Cells(NN, 1).Value = "Private Sub onlyOnce()"
NN = NN + 1: .Cells(NN, 1).Value = "Rem ' Range(""" & rngSelected.Address(, , , True) & """).Clear"
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 結合状態を処理"
For Each cel In rngSelected '結合状態を処理----------------
With cel
If .MergeCells Then '結合状態になっているセルを処理
If .MergeArea.Item(1).Address = .Address Then
NN = NN + 1
dataToFil = Replace(modelMRG, "Adrs", .MergeArea.Cells.Address(0, 0))
ThisWorkbook.Sheets("出力Wsh").Cells(NN, 1).Value = dataToFil
End If
End If
End With
Next
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 数式セル以外をまとめて処理"
rslt = sameKindS(rngSelected, modelVAL2, "値")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 数式セルをまとめて処理"
rslt = sameKindS(rngSelected, modelFML, "数式")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 標準外書式セルをまとめて処理"
rslt = sameKindS(rngSelected, modelFME, "セル書式")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 塗りつぶしセルをまとめて処理"
rslt = sameKindS(rngSelected, modelCLR, "塗りつぶし")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = "End Sub"
' .Range("A1").Resize(NN, 1).Copy
End With
End Sub
Private Function sameKindS(rng As Range, modelFMS, Optional aim As String = "値") '一般形
Dim dic As Object
Dim cel As Range
Dim Adrs As String
Dim AdrsBreak
Dim sNum As String
Dim eachKey
Dim NN As Long
Dim dataToFil
Dim ItemVal
Set dic = CreateObject("Scripting.Dictionary") ' 連想配列の定義
For Each cel In rng
ItemVal = Empty
Select Case aim
Case "値"
If Not cel.HasFormula And Not IsEmpty(cel.Value) Then
ItemVal = IIf(IsError(cel.Value2), cel.Formula, cel.Value2)
End If
Case "数式"
If cel.HasFormula Then
ItemVal = cel.FormulaR1C1Local
End If
Case "セル書式"
If cel.NumberFormatLocal <> "G/標準" And _
TypeName(cel.Value) <> "Currency" Then '標準外の書式を反映させる。通貨型は面倒なので処理外
ItemVal = cel.NumberFormatLocal
End If
Case "塗りつぶし"
If cel.Interior.ColorIndex <> -4142 Then '塗りつぶしがあるセルを処理
ItemVal = cel.Interior.ColorIndex
End If
End Select
If Not IsEmpty(ItemVal) Then
If dic.Exists(ItemVal) Then
AdrsBreak = Split(dic(ItemVal), "#")
sNum = AdrsBreak(0) + 1
dic(ItemVal) = sNum & "#" & AdrsBreak(1) & cel.Address(0, 0) & " "
Else
dic.Add ItemVal, "1#" & cel.Address(0, 0) & " "
End If
End If
Next
Dim rslt()
Dim brd
ReDim rslt(0 To Application.Max(0, dic.Count - 1))
NN = 0
For Each eachKey In dic
AdrsBreak = Split(dic(eachKey), "#")
Adrs = Replace(RTrim(AdrsBreak(1)), " ", ",")
Adrs = AddressUnited(Adrs) 'バラバラのAddressを統合
For Each brd In Split(Adrs, "#!#")
If brd <> "" Then
dataToFil = IIf(Application.IsText(eachKey), """", "") & Replace(eachKey, """", """""") & _
IIf(Application.IsText(eachKey), """", "")
dataToFil = Replace(modelFMS, "Adrs", brd) & dataToFil
NN = NN + 1
If NN - 1 > UBound(rslt) Then
ReDim Preserve rslt(0 To NN - 1)
End If
rslt(NN - 1) = dataToFil
End If
Next
Next
sameKindS = rslt
End Function
Private Function AddressUnited(adr) 'バラバラのAddressを統合
Dim scopeRange As Range
Dim adrRemain As String
Dim adrForRowProc As String
Dim adrForColProc As String
Set scopeRange = Range(Split(adr, ",")(0))
adrRemain = "," & adr & ","
Do While Not scopeRange Is Nothing
uniteRowDir scopeRange, adrRemain
adrForRowProc = adrForRowProc & scopeRange.Address(0, 0) & ","
If Len(adrRemain) < 4 Then
Set scopeRange = Nothing
Else
Set scopeRange = Range(Split(adrRemain, ",")(1))
End If
Loop
Set scopeRange = Range(Split(adrForRowProc & ",", ",")(0))
adrRemain = "," & adrForRowProc
Do While Not scopeRange Is Nothing
uniteColDir scopeRange, adrRemain
adrForColProc = adrForColProc & scopeRange.Address(0, 0) & ","
If Len(adrRemain) < 4 Then
Set scopeRange = Nothing
Else
Set scopeRange = Range(Split(adrRemain, ",")(1))
End If
Loop
AddressUnited = get小分け(adrForColProc) '10セル以上は長いので同じ構文でも分割作成
End Function
Function get小分け(adrForColProc)
Dim strSRC
Dim brDown, Cntr, sss, QQ, adrsUnit, numOfadrs
brDown = Split(adrForColProc, ",")
numOfadrs = UBound(brDown) '対象個数
adrsUnit = Int((numOfadrs - 1) / 10) + 1
adrsUnit = Application.RoundUp(UBound(brDown) / adrsUnit, 0) 'まとめるアドレスの数
For Cntr = 0 To numOfadrs - 1 Step adrsUnit
sss = stEd(Cntr, Application.Min(numOfadrs - 1, Cntr + adrsUnit - 1), brDown)
strSRC = IIf(strSRC = "", sss, strSRC & "#!#" & sss)
Next Cntr
get小分け = strSRC & "#!#"
End Function
Function stEd(st, ed, ary)
Dim NN, str
str = ary(st)
For NN = st + 1 To ed
str = str & "," & ary(NN)
Next NN
stEd = str
End Function
Private Sub uniteRowDir(ByRef scopeRange, ByRef adrRemain)
Dim brdAry
brdAry = Split(adrRemain, ",")
adrRemain = Replace(adrRemain, "," & brdAry(1) & ",", ",") 'アドレス文字列から除外
If Range(brdAry(1)).Cells(1, 2).Address(0, 0) = brdAry(2) Then '右横に同じものあり
Set scopeRange = Range(scopeRange, Range(brdAry(2)))
uniteRowDir scopeRange, adrRemain
End If
End Sub
Private Sub uniteColDir(ByRef scopeRange, ByRef adrRemain) '直下が同じ範囲かチェック
Dim brdAry
Dim adrsUnder As String
brdAry = Split(adrRemain, ",")
adrRemain = Replace(adrRemain, "," & scopeRange.Rows(scopeRange.Rows.Count).Address(0, 0) & ",", ",") 'アドレス文字列から除外
adrsUnder = scopeRange.Rows(scopeRange.Rows.Count + 1).Address(0, 0) '結合セル対策
If adrRemain Like "*," & adrsUnder & ",*" Then '真下に同じものあり
Set scopeRange = Range(scopeRange, Range(adrsUnder))
uniteColDir scopeRange, adrRemain
End If
End Sub
（β） 2015/10/28(水) 14:19
Private Sub onlyOnce()
Rem ' Range("[部品データベース.xlsm]Sheet2!$A$1:$G$15").Clear
Rem 結合状態を処理
Rem 数式セル以外をまとめて処理
Range("B1").Value = "SS500"
Range("C1").Value = "ＹＧ500"
Range("D1").Value = "AB050"
Range("E1").Value = "CD550"
Range("F1").Value = "ABC300"
Range("G1").Value = "CDE150"
Range("A3").Value = "MP-*EMC-13HK-3D"
Range("A4").Value = "MP-*IP085C-SDM5"
Range("A5").Value = "MP-*M201400"
Range("A6").Value = "MP-00021182"
Range("A7").Value = "MP-00021205"
Range("A8").Value = "MP-00030687"
Range("A9").Value = "MP-00880152"
Range("D9:E9,G9").Value = 8
Range("F9").Value = 4
Range("A10").Value = "MP-01020542"
Range("A11").Value = "MP-01021194"
Range("A12").Value = "MP-01030026-2"
Range("A13").Value = "MP-01030655"
Range("A14").Value = "MP-01031117"
Range("A15").Value = "MP-0103137"
Rem 数式セルをまとめて処理
Rem 標準外書式セルをまとめて処理
Rem 塗りつぶしセルをまとめて処理
End Sub
Range("A7").Value = "MP-*M201400"
Range("B7").Value = "ﾍｯﾄﾞ固定ﾌﾞﾛｯｸ"
Range("C7").Value = "HEAD FIXING BLOCK"
Range("A8").Value = "MP-00021182"
Range("B8,B12").Value = "ﾓｰﾀ ASSY (X)"
Range("A9").Value = "MP-00021205"
Range("B9,B13").Value = "ﾓｰﾀ ASSY (Y)"
Range("C9").Value = "Y MOTOR"
Range("A10").Value = "MP-00030687"
Range("B10").Value = "紙ｾﾝｻｰ板ASSY(A1)"
Range("A11").Value = "MP-00880152"
Range("B11").Value = "取扱いマーク銘板"
Range("C11").Value = "NAME PLATE-HANDLING MARK"
Range("A12").Value = "MP-01020542"
Range("A13").Value = "MP-01021194"
Range("C13").Value = "Y MOTOR ASSY CG-90I"
Range("A14").Value = "MP-01030026-2"
Range("B14").Value = "ｸﾞﾘｯﾌﾟﾛｰﾗ (単品価格)"
Range("A15").Value = "MP-01030655"
Range("B15").Value = "ﾃﾝｼｮﾝﾌﾟｰﾘ ASSY"
Rem 数式セルをまとめて処理
Rem 標準外書式セルをまとめて処理
Range("E2:AB2").NumberFormatLocal = "yyyy/mm"
Range("A4:C15").NumberFormatLocal = "@"
Rem 塗りつぶしセルをまとめて処理
End Sub
（Lila） 2015/10/28(水) 15:40
Private Sub onlyOnce()
Rem ' Range("[故障部品データベース.xlsm]Sheet1!$A$1:$AB$15").Clear
Rem 結合状態を処理
Range("A1:A3").Merge
Range("B1:B3").Merge
Range("C1:C3").Merge
Range("D1:D3").Merge
Range("E1:P1").Merge
Range("Q1:AB1").Merge
Rem 数式セル以外をまとめて処理
Range("A1").Value = "部品ｺｰﾄﾞ"
Range("B1").Value = "品名"
Range("C1").Value = "英語品名"
Range("E1").Value = "AB050"
Range("Q1").Value = "CD550"
Range("E2,Q2").Value = 41944
Range("F2,R2").Value = 41974
Range("G2,S2").Value = 42005
Range("H2,T2").Value = 42036
Range("I2,U2").Value = 42064
Range("J2,V2").Value = 42095
Range("K2,W2").Value = 42125
Range("L2,X2").Value = 42156
Range("M2,Y2").Value = 42186
Range("N2,Z2").Value = 42217
Range("O2,AA2").Value = 42248
Range("P2,AB2").Value = 42278
Range("A5").Value = "MP-*EMC-13HK-3D"
Range("B5").Value = "電源装置 保守用"
Range("A6").Value = "MP-*IP085C-SDM5"
Range("B6").Value = "照射器具 保守用"
Range("C6").Value = "UV LIGHTING UNIT"
Range("A7").Value = "MP-*M201400"
Range("B7").Value = "ﾍｯﾄﾞ固定ﾌﾞﾛｯｸ"
Range("C7").Value = "HEAD FIXING BLOCK"
Range("A8").Value = "MP-00021182"
Range("B8,B12").Value = "ﾓｰﾀ ASSY (X)"
Range("A9").Value = "MP-00021205"
Range("B9,B13").Value = "ﾓｰﾀ ASSY (Y)"
Range("C9").Value = "Y MOTOR"
Range("A10").Value = "MP-00030687"
Range("B10").Value = "紙ｾﾝｻｰ板ASSY(A1)"
Range("A11").Value = "MP-00880152"
Range("B11").Value = "取扱いマーク銘板"
Range("C11").Value = "NAME PLATE-HANDLING MARK"
Range("A12").Value = "MP-01020542"
Range("A13").Value = "MP-01021194"
Range("C13").Value = "Y MOTOR ASSY CG-90I"
Range("A14").Value = "MP-01030026-2"
Range("B14").Value = "ｸﾞﾘｯﾌﾟﾛｰﾗ (単品価格)"
Range("A15").Value = "MP-01030655"
Range("B15").Value = "ﾃﾝｼｮﾝﾌﾟｰﾘ ASSY"
Rem 数式セルをまとめて処理
Rem 標準外書式セルをまとめて処理
Range("E2:AB2").NumberFormatLocal = "yyyy/mm"
Range("A4:C15").NumberFormatLocal = "@"
Rem 塗りつぶしセルをまとめて処理
End Sub
（Lila） 2015/10/28(水) 15:41
実際に使用しているCシートからフィルターでBシートに乗っている2種類のみの数値を出しています。
Private Sub onlyOnce()
Rem ' Range("'[30-21 MTBF 機種別小分類.xlsx]Sheet1'!$A$1:$C$25").Clear
Rem 結合状態を処理
Rem 数式セル以外をまとめて処理
Range("A1").Value = "設定月"
Range("B1").Value = "集計区分"
Range("C1").Value = "稼働台数"
Range("A2:A3").Value = 42278
Range("B2,B4,B6,B8,B10,B12,B14").Value = "AB050"
Range("C2").Value = 60
Range("B3,B5,B7,B9,B11,B13,B15:B25").Value = "CD550"
Range("C3").Value = 654
Range("A4:A5").Value = 42248
Range("C4,C24").Value = 57
Range("C5").Value = 651
Range("A6:A7").Value = 42217
Range("C6").Value = 37
Range("C7").Value = 598
Range("A8:A9").Value = 42186
Range("C8").Value = 28
Range("C9").Value = 565
Range("A10:A11").Value = 42156
Range("C10").Value = 21
Range("C11").Value = 529
Range("A12:A13").Value = 42125
Range("C12").Value = 10
Range("C13").Value = 491
Range("A14:A15").Value = 42095
Range("C14").Value = 2
Range("C15").Value = 465
Range("A16").Value = 42064
Range("C16").Value = 438
Range("A17").Value = 42036
Range("C17").Value = 354
Range("A18").Value = 42005
Range("C18").Value = 317
Range("A19").Value = 41974
Range("C19").Value = 282
Range("A20").Value = 41944
Range("C20").Value = 242
Range("A21").Value = 41913
Range("C21").Value = 207
Range("A22").Value = 41883
Range("C22").Value = 175
Range("A23").Value = 41852
Range("C23").Value = 104
Range("A24").Value = 41821
Range("A25").Value = 41791
Range("C25").Value = 16
Rem 数式セルをまとめて処理
Rem 標準外書式セルをまとめて処理
Range("A1:A25").NumberFormatLocal = "yyyy/mm/dd"
Rem 塗りつぶしセルをまとめて処理
Range("A1:C1").Interior.ColorIndex = 15
End Sub
Rem 塗りつぶしセルをまとめて処理
End Sub
（Lila） 2015/10/28(水) 15:48
作業ありがとうございました。
結果からいえば、ｍｏｍｏさんのユーティリティでレイアウトアップいただいてもわかったことでした。
Ｂシートですが、日付行は ３行目じゃなかったですか？ そちらで使っているシートは２行目のようですね。３行目は空白行。 なので、yyyymm がすべて"" になり、マッチしないということなんですが、 ２行目、３行目、どちらが正しかったですか？
（β） 2015/10/28(水) 17:11
なるほど、見ている行が違ったのですね！
恐らく、3行目はレイアウトを変えた方が･･･と迷っていた時に、1行目をグループとして一瞬だけ此処にレイアウトとして出したものだったかと思います。
2行目が現在のシートになって居ます。
変更箇所は
＞yyyymm = Format(c.EntireColumn.Cells(3).Value, "yyyymm")
の (3) を (2) にする形で合っていますか？？
（Lila） 2015/10/28(水) 17:17
>>の (3) を (2) にする形で合っていますか？？
はい。そのように変更してください。
（β） 2015/10/28(水) 17:23
例えば、書き出しを新規ブックではなく、Bブックのシート2等にしたい場合、
＞Set shB = ActiveWorkbook.Sheets(1)
ここを
＞Set shB = ThisWorkbook.Sheets("Sheet2")
こう変更でBブックのシート2へ書き出しされるのでしょうか？？
（Lila） 2015/10/29(木) 08:43
それだけでは、だめですね。 現在のコードは
ThisWorkbook.Sheets("Sheet1").Copy '故障部品
Set shB = ActiveWorkbook.Sheets(1)
つまり、既存の Sheet1の内容をいったんコピーして、それを加工します。 ですから、これをマクロブックのSheet2にするなら、
Set shB = ThisWorkbook.Sheets("Sheet2")
shB.Cells.Clear
ThisWorkbook.Sheets("Sheet1").Cells.Copy shB.Range("A1")
こんなコードになりますね。
（β） 2015/10/29(木) 09:57
これは
＞ Set shB = ThisWorkbook.Sheets("Sheet2")
「shB」にマクロブックのシート2を格納して
＞ shB.Cells.Clear
シート2の情報をクリアして
＞ ThisWorkbook.Sheets("Sheet1").Cells.Copy shB.Range("A1")
シート1をコピーして、シート2のA1へ貼り付け･･･
と言うことでしょうか･･･。
こうして細かく区切ったコードだと、なんとなくどういう動作をしているのか、判ってきましたが、じゃあこれを加工してみろと言われると、まだまだ「？？？」状態ですね･･･^^;
（Lila） 2015/10/29(木) 10:13
はい、この３行でやっていることは Lilaさんの理解の通りです。 確かに長いコードだと、見るだけでうんざりということがあるかもしれませんが、丹念に（がまんして）おいかけていくと しょせんが細かく区切ったコードの寄せ集めですから、きっと理解もできるし、加工もできるようになると思いますよ。
（β） 2015/10/29(木) 10:29
とりあえず、色々触って実践しながらまた解らないことが出ましたら、質問させて頂きに来ます(^o^)/
βさん、ありがとうございました！
（Lila） 2015/10/29(木) 10:40
とりあえずAブック集約シートとBブックの大項目同士が合っているのか確認します･･･
（Lila） 2015/10/29(木) 11:02
そして、計算結果を出した後に、グループ分けをしたのですが、
グループ分けタブで4行目（A4セル）に記載したグループに、5行目（A5セル）のグループに入らなければいけないものがひとつ入ってしまいました･･･
そのA4セルグループに入ってしまったものは、ちゃんと5行目に記載しています（B5セル）
これはどういった事が考えられますでしょうか･･･？
（Lila） 2015/10/29(木) 11:20
元々が、各人のやりかたで、入力様式が多種多様というものを集約しているようですので、 Lilaさんの補正作業も大変だなと感じます。 難しいとは思いますが、やはり、集計ということを、各人に理解してもらい、入力様式の統一をお願いしていくということも 必要だと思います。
それはさておき。
>>計算結果を出した後に、グループ分けをしたのですが
これは、前回の結果シートをグループコード別に別シートに分割した、その方法で、今回の Bシートを シート分割したということですか？ で、そこで、正しくグループ分けされなかったということなら、そのコードをアップしてもらわないと コメントができないのですが？
そうではなく、今回の処理そのもので不具合があったということですか？
（β） 2015/10/29(木) 11:38
そうですねぇ･･･。
その通りだと思いますが、実際の所、何を言っても聞く耳をお持ちでないようなので･･･。
社員の方々が気付くしかないですし、この辺りはいずれ私が退職した後に泣けばいいと思います。
＞ これは、前回の結果シートをグループコード別に別シートに分割した、その方法で、今回の Bシートを
＞ シート分割したということですか？
＞ で、そこで、正しくグループ分けされなかったということなら、そのコードをアップしてもらわないと
＞ コメントができないのですが？
今回の計算が完成する前に、未計算のBシートを分割するコードを頂いていたので、計算後のBシートをグループ分けしたのですが（コードは頂いたものの"Sheet1" を "Sheet2"に変更したのみ）、そこでの不具合（？）です。
コードを見ていて、ん？と思ったのですが、もしかして「12」を「6」に変更すれば良いだけの事でしょうか･･･？？？
（未計算時は12ヶ月だが、計算後は6ヶ月なので）
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 12 '集約ブロックの先頭列を抽出
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, 12)) > 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, 12).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
（Lila） 2015/10/29(木) 11:49
いま、そうかなと思ってレスしようとしたところでした。
はい。Aシートは12列単位で分割していますが、できあがりのBシートは6列単位なので 後ろの6列が、どのグループであろうと、その前のグループとして分割されてしまいます。
コード内で 12 が何回か登場しますので、それらをすべて 6 に変更して試してください。
（β） 2015/10/29(木) 11:54
まったくテーマとは異なりますが。
今回のように 分割マクロ を複数種類、ロジックはほとんど同じで、ほんのちょっと条件が異なるものを作っておくと 要件変更などがあった場合、複数、間違いなく同じように変更が必要になります。 これを共通プロシジャとして作っておくと、ロジックが１か所になり、保守性が向上します。
いずれ、余力ができたおりに検討してみてください。
以下の例は、わざわざ共通化するまでもないシンプルなものですが、考え方として。
●別々に用意するパターン。
Sub 処理1()
Dim sh As Worksheet
Set sh = Sheets("Sheet1")
sh.Range("A5").Value = "ABC"
End Sub
Sub 処理2()
Dim sh As Worksheet
Set sh = Sheets("Sheet2")
sh.Range("B8").Value = "XYZ"
End Sub
●共通プロシジャ化したパターン
Sub 処理1()
共通処理 Sheets("Sheet1"), "A5", "ABC"
End Sub
Sub 処理2()
共通処理 Sheets("Sheet2"), "B8", "XYZ"
End Sub
Sub 共通処理(sh As Worksheet, adr As String, val As String)
sh.Range(adr).Value = val
End Sub
（β） 2015/10/29(木) 14:42
共通プロシジャ･･･
以前作っていただいた「フォルダ又はファイルを読み込む」みたいなものの事･･･でしょうか･･･？？？
（Lila） 2015/10/29(木) 15:36
そうですね。
たとえば今回の分割が同じマクロブックにあるなら
Sub 分割(fSh as Worksheet,cols as Long)
といった記述にして、中にある Dim fSh as Worksheet を消し、12 や 6 を cols にしておけば
使う場合は
Sub 分割1()
分割 Sheets("Sheet1"),12
End SUb
とか
Sub 分割2()
分割 SHeets("Sheet1"),6
End Sub
こんな感じになります。
（β） 2015/10/29(木) 15:59
分割の方には、
＞ Sub 分割(fSh as Worksheet,cols as Long)
＞ といった記述にして、中にある Dim fSh as Worksheet を消し、12 や 6 を cols にしておけば
ここを修正した、コードを書いておき
＞ Sub 分割1()
＞ 分割 Sheets("Sheet1"),12
＞ End SUb
12行欲しかったらこちらで呼び出し
＞ Sub 分割2()
＞ 分割 SHeets("Sheet1"),6
＞ End Sub
6行の時はこちらで呼び出す、という事ですか？？
以前の部品更新の時のコードで言うと、
どちらも
Sub 使用部品更新1 or 2()
～～～
Sub
の後ろに
Sub 更新()
データ取り込み SHeets("シート名")
End Sub
とすれば呼び出せると言うことですか？？
あ、あとすいません。
＞shB.Cells.Clear
で消されるのは「Sheet2」のセル値だけで、例えばマクロを登録したボタン（図形）はそのまま上書き、というか上にいくつも重なっていってしまいますか？
（Lila） 2015/10/29(木) 16:17
まず、共通サブルーティン化については、ちょっと、お先走ったかもしれませんね。 かえって混乱させたのかな？
たとえば、今のBブックに変換前の12列単位のSheet1と変換後の6列単位のSHeet2がありますね。 分割 をコメントしたような構造にしておいて、
Sub 分割A()
分割 Sheets("Sheet1"),12 'あるいは Call 分割(SHeets("Sheet1"),12)
End SUb
Sub 分割B()
分割 Sheets("Sheet2"),6 'あるいは Call 分割(SHeets("Sheet2"),6)
End SUb
こうすれば、異なるシートの分割が、１つのプロシジャで処理できますよということなんです。（それが必要なら）
で、シート上のボタンの件。
Cells.Copy とやると、ボタンもコピーされます。 でも Cells.Clear ではボタンはクリアされません。
ですから、コピー元にボタンがあって、この処理を繰り返すと、コピー先にボタンがどんどん追加されていきますね。
対処方法は３つ。
１．コードを変更して、ボタンをコピーせず、そのほかのものは（セルの結合状態含めて）コピーするというやりかたにかえる。 ２．コピーしたあとボタンを消すコードを追加。 ３．コピー元シートにはボタンはおかない。別途、操作シートをつくり、そのシート上に、Ｂブック上で行うボタンを配置する。
３．ならコード変更不要です。 ２．なら
ThisWorkbook.Sheets("Sheet1").Cells.Copy shB.Range("A1")
の下に
shB.Buttons.Delete
をいれてください。
★ただし、それがボタンではない場合、からぶりします。図形というのは具体的に何ですか？ オートシェープでしょうか？あるいは、図 でしょうか？ それによって、削除するコードがかわりますので。
（β） 2015/10/30(金) 07:55
＞ ★ただし、それがボタンではない場合、からぶりします。図形というのは具体的に何ですか？
＞ オートシェープでしょうか？あるいは、図 でしょうか？
＞ それによって、削除するコードがかわりますので。
挿入タブの図形ですね。
矢印とかハートとか出来るあれです。
（Lila） 2015/10/30(金) 08:25
>>1年数値のままグループタブ分けと計算後のグループタブ分けがひとつのモジュールで
う～ん・・・モジュールという概念とは違うんですが・・・ ↑であげた例を踏まえると 「分割」という「１つのプロシジャ」で、6か月シートも12か月シートも処理できますよということなんです。 分割A、分割B、それと、分割。この３つは、同じ【モジュール】に配置したほうがわかりやすいでしょうけど、別々のモジュールに記述してもいいんです・・・
ちょっとわかりにくいですかね？
で、図形の削除ですけど、ループで取り出して形式を調べながら削除するのが安全なんですが、面倒なので
shB.Shapes.SelectAll
Selection.Delete
↑で連絡した shB.Buttons.Delete のかわりに、この２行を。
（β） 2015/10/30(金) 09:07
別のモジュールに配置しておいて、また別のモジュールで好きな組み合わせ「分割」+「分割A」、「分割」+「分割B」、「分割」+「分割A」+「分割B」という呼び出しを作成できるということですか･･･？？？
＞↑で連絡した shB.Buttons.Delete のかわりに、この２行を。
追加して実行してみました！
削除は出来ていなかったようですが、選択状態になっていたので、楽に消せました^o^！
ありがとうございます！
（Lila） 2015/10/30(金) 09:17
>>削除は出来ていなかったようですが
わぁ、ごめんなさい。必ずしも、このシートがアクティブシートではなかったですね。 しかも、その場合、図形が削除されないだけではなく、実行時にアクティブだったシートで選択されていたセルが削除されてしまうという とんでもない、間違いコードでした。
１．Selection.Delete を消して操作で削除してもらうか、あるいは、 ２．Dim Sp As Shape を追加したうえで
shB.Shapes.SelectAll
Selection.Delete
これをやめて
For Each sp In shB.Shapes
sp.Delete
Next
ところで、共通プロシジャについては、ちょっとお先走った提案だったかも。 これはこれで、じっくりと、説明したほうがいいと思います。 ご希望なら、少しまとまったメモを作成します。 あるいは、それは、将来のテーマとして、今は、そのことを忘れてもらってもいいですが。
（β） 2015/10/30(金) 10:00
＞ ところで、共通プロシジャについては、ちょっとお先走った提案だったかも。
＞ これはこれで、じっくりと、説明したほうがいいと思います。
＞ ご希望なら、少しまとまったメモを作成します。
分けて実行する、というのが良くわかってないので、以前のコードもそのまま同じモジュールに貼り付けています･･･^^;
βさんさえ良ろしければ、是非お願いします！
（Lila） 2015/10/30(金) 10:16
まず、標準モジュールについて整理しましょう。 標準モジュールはＶＢＥ画面で、挿入することによって初期値の名前としては Module1、Module2、・・・と何枚でも作成できますね。 もちろん、Module1 だけで、そこにすべてのマクロを記述してもいいですし、処理の種類別にマクロを分けて配置してもいいですし、 あるいは Module1にはメイン処理、Module2には共通サブプロシジャといったようにわけて配置してもいいですね。
Moduleを自宅の部屋だと考えて、すべて１部屋だけに家具を詰め込んで、そこだけで生活するのもいいですし 寝室や勉強部屋や仕事部屋といったようにわけてもいいですね。「標準モジュール」とは、そういった「部屋」です。
次に、「プロシジャ」を考えましょう。いわゆるマクロ、Sub から End Sub までの処理プログラムのことです。
Sub 処理1()
MsgBox "Hello"
End Sub
Sub 処理2()
MsgBox "Good Bye"
End Sub
こんな２つのプロシジャがあったとします。これらが、同じモジュールにあるか別々のモジュールにあるか、 それは実行上、どちらでもかわりません。いずれにしても、単独で動く２つの実行マクロがあるわけですね。
で、この例は、単純な例なんですが、この中身（MsgBoxだけの部分）が、今回の分割処理のような長いコードだったとします。 処理1 が 12列用、処理2が 6列用だったとします。 で、今回のように、コピーしたあと図形を削除したいといった要件がでたとします。 あるいは、今までもあったようにロジックに間違いがあって、そこを修正するとします。 そうすると、２つのコードを同じように直さなきゃいけませんね。
もう１つ、別のポイントで。
Sub 処理1()
MsgBox "Hello"
End Sub
これは、単独で実行可能なプロシジャ（マクロ）ですね。 この形式の他に
Sub hoge(引数群) 引数を参照した処理 End SUb
こんなプロシジャを書くことができます。 （引数は、本来は「いんすう」が正しい読み方ですが、「因数」等との区別のため「ひきすう」と呼ぶのが一般的です）
たとえば
Sub 処理1()
hoge "Hello"
End Sub
Sub Hoge(s As String)
MsgBox s
End Sub
処理1 では、実際の処理を行わず、実際の処理を行う Hoge というサブプロシジャに 引数として "Hello" を渡し Hoge では、渡された引数を参照して処理を行います。
こうしておけば、処理2 のほうも
Sub 処理2()
hoge "Good Bye"
End Sub
と書くだけで、実際の処理は Hoge がやってくれます。
なにか変更があった場合、Hoge を変更すれば 処理1 も 処理2 も、変更後のロジックで動くことになります。
この時、処理1、処理2、Hoge を 同じモジュールに書こうが、別モジュールに分けて書こうが、それは実行とは関係のない話。 どのようにモジュール分けをしておいたらLilaさんが管理しやすいかという、そういった観点で１つもモジュールにするなり 別々のモジュールにするなり、そこは好きなように配置すればいいんです。
例では、引数として 1 つだけを与えましたが、共通的に使われるロジックの中で、処理ごとに異なる条件、 対象シートであったり、処理単位の列数であったり、異なる条件分、２つだったり３つだったり４つだったり、必要なだけ与えます。
今回の分割で、その形をとろうとした場合、もしかしたら、分割後のシート名をどうするのかも条件になるかもしれませんね。 さもなければ 処理1 も 処理2 も、同じシート名として作成、結果、先に作ったシートが後の処理で上書きされますので。
とりあえず、ここまで。
わからないところがあれば（あると思いますが）遠慮なく質問してください。
（β） 2015/10/30(金) 11:19
ファイルを開く や フォルダを開く というのを実行していたのは使用部品更新プロシジャではなく、データ取り込みプロシジャで行っている･･･？という考え方でしょうか
（Lila） 2015/10/30(金) 11:40
その実例で説明したほうがわかりやすかったですね。 共通プロシジャに渡す引数も１つだけのシンプルなものでしたから。
マクロ名は何でもいいのですが、 Test1 これは、対象ブックを複数選んで処理。 Test2 これは、対象フォルダを１つ選んで、その中のすべてのブックを対象にして処理。
処理そのものは全く同じなんですが、ブックを選択する方式が異なるので、別のマクロ（Test1とTest2)にせざるを得なかったわけです。
Sub Test1()
ファイル選択ダイアログから対象ブックを複数選択
複数選択されたブックを１つずつ繰り返しで取得
そのブックを開く
データ取り込み wb.Sheets("データシート") '★データ取り込み実行
繰り返し
End Sub
Sub Test2()
フォルダ選択ダイアログで対象フォルダを１つ選択
フォルダ内のブックを１つずつ繰り返しで取得
そのブックを開く
データ取り込み wb.Sheets("データシート") '★データ取り込み実行
繰り返し
End Sub
で、これらとは別に
Sub データ取り込み(shF As Worksheet)
長～い処理コード
End Sub
これが「１つだけ」記述されていたわけですね。
Test1やTest2では、それぞれで開いたブックのシートを引数として データ取り込み に渡して処理させます。
このデータ取り込み処理については、要件変更や不具合修正等で、何度も手を入れましたね。 仮に、このデータ取り込み部分が、共通プロシジャ化されておらず、Test1とTest2の★のところに それぞれ、長～いコードを記述してあったとしますと、変更のたびに、２つのマクロを修正しなければいけなかったわけです。
でも、「処理」の部分を、切り出して、共通プロシジャ化しておくことによって、変更作業は データ取り込み マクロのみでよかったですね。
ご質問の ファイルを開くのはどこがやっているかということについては、Test1 または Test2 で、それぞれやっています。 開いたブックのシート処理を共通プロシジャである データ取り込み でやっているということです。
で、繰り返しになりますが、Test1、Test2、データ取り込み の３つのマクロが、同じ標準モジュールにあろうと 別の標準モジュールにあろうと、それは、家の中で リビングに家具を置くか、寝室におくかということだけの違いで 処理そのものにとっては、関係のないことになります。
（β） 2015/10/30(金) 13:15
今までのコメントは、関連のマクロを【標準モジュール】に記述してあるということを前提にしています。 【シートモジュール】に記述している場合は、ちょっとだけ説明がかわってくるんですが。
実際は、どこにコードを記述していますか？
（β） 2015/10/30(金) 14:14
なんとなく理解出来てきました！
＞ 実際は、どこにコードを記述していますか？
どこに書くのかちょっと解ってなかったので、最初に色々調べていたところ、標準モジュールを挿入して書く、というものを見つけたので、標準モジュールにそれぞれ名前を付けて置いています
（Lila） 2015/10/30(金) 15:28
>>標準モジュールにそれぞれ名前を付けて置いています
それはいいことだと思います。
（β） 2015/10/30(金) 16:41
月数が変わり、2014/12～2015/11までで使用しており、今の所確認済みで、計算が反映できていないのが、「BA～BL」の12列での事なのですが、これはまだ数値が入っているのが「2015/10」と「2015/11」（BK～BL列）になっているので、もしかしたらBA列の「2014/12」でデータがないので次の項目（BM列から12列）へ飛んでしまっているのかな？と思ったのですが、実際はどうなのでしょうか･･･？
よろしくお願いします。
（Lila） 2015/11/25(水) 13:38
With shB
With .UsedRange
mCol = .Columns.Count
mRow = .Rows.Count
End With
For j = mCol - 11 To 5 Step -12 '最終ブロックの先頭列からE列まで 12列単位で処理
sv = .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 = 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
でも、後ろから12列ごとに処理をしている、という事は、最新月（この場合だとBL列）で計算が出来ていないのはおかしい･･･？？のかな？？と･･･
（Lila） 2015/11/25(水) 14:15
例によってすっかり忘却の彼方です。 いくつか処理があったわけですが、分割とか故障率とか・・・ アップされたコードを見る限り、故障率？ BA～BL がおかしくなっているということは 集計コードが少なくとも４つ以上 Bブックにあるということですね。 そのときの BA～BL に対する集計コードと月、この組み合わせの部品情報が CブックやAブックに、ちゃんとあって、でも計算されていないということですか？
（β） 2015/11/25(水) 14:24
そうですね、故障率の部分になりまして、組み合わせの情報が全てのブックにあり、計算がされていない状態ですね。
他の箇所もざっと確認した所、データ記載があるのにも関わらず、計算されていない箇所がありました。
でも、計算できている部分が多数で、原因がわからずです･･･。
BA～BL列も含め、計算されていない箇所の全ブック存在確認をもう一度細かくしてみます。
頂いたコードは以下です。
Sub 故障率()
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("機種別小分類.xlsx").Sheets("機種別小分類") '稼働台数（★ブック名、シート名変更箇所）
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") & 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 = c.EntireRow.Cells(1).Value & vbTab & 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 = .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 = 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
（Lila） 2015/11/25(水) 14:41
いままでもありましたが、マッチする【はず】なのに、マッチしない。 コード不備もありましたが、多くは、セルにある値そのものが 「見かけ上にているけど異なる」といったものだったと思います。
サブプロシジャ
Function normalize(s As String) As String
normalize = WorksheetFunction.Clean(WorksheetFunction.Trim(s))
End Function
これを追加しておいて、 故障率プロシジャ内で比較キーをセットしている４か所を以下のように変更すると どうなりますか？
k = Format(c.Value, "yyyymm") & c.Offset(, 1).Value '年月+集約コード
これを
k = Format(c.Value, "yyyymm") & normalize(c.Offset(, 1).Value) '年月+集約コード
k = c.EntireRow.Cells(1).Value & vbTab & c.EntireColumn.Cells(1).Value '部品番号+集約コード
これを
k = normalize(c.EntireRow.Cells(1).Value) & vbTab & normalize(c.EntireColumn.Cells(1).Value) '部品番号+集約コード
sv = .Cells(1, j).Value '集約コード
これを
sv = normalize(.Cells(1, j).Value) '集約コード
parts = c.EntireRow.Cells(1).Value
これを
parts = normalize(c.EntireRow.Cells(1).Value)
（β） 2015/11/25(水) 16:48
データ的には、当然ですがBブックにあるものは、Aブック（部品番号）、Cブック（稼働台数）にもありました。
BブックのSheet1を作成段階で使用する、故障部品交換リストにも当然ですがデータはありました。（こちらを部品番号と日付で紐付け転記している為）リストにはあるけれど、Bブックの方には品番がない、というものも数点ありましたが、この辺りはBブック基点でのマクロになるので関係ないのかなと思っていますが･･･
（Lila） 2015/11/25(水) 17:16
そうですかぁ・・・・
>>この辺りはBブック基点でのマクロになるので関係ないのかなと思っていますが･
はい、Bブック基点ですから、関係ないですね。 こちらでも、いろいろ調べてみます。
（β） 2015/11/25(水) 17:25
とりあえず報告します。
ＢブックのデータをＢＬ列までに、集約コードを増やしたものにして、（Lila） 2015/11/25(水) 14:41 でアップされたコードを実行。 結果は、全く計算されず（マッチせず）空白。
で、こちらに保存している、こちらの最新コードで実行すると、正しく結果が計算され転記されました。
同じデータを相手にしているわけですから、コードが、どこか違うということですね。 ちょっと、そちらのコードと、こちらのコードをつきあわせてみます。
（β） 2015/11/25(水) 17:59
コード、１か所、違い発見。
下のほうにあるコード
こちら yyyymm = Format(c.EntireColumn.Cells(3).Value, "yyyymm") そちら yyyymm = Format(c.EntireColumn.Cells(2).Value, "yyyymm") Bブックの日付行ですが、３行目じゃなかったですか？ なぜ、そちらのコードは２行目になっているんでしょう？
（β） 2015/11/25(水) 19:30
確認なのですが、サブプロシジャを別に置くか、コードの一番上に置いて、そのほかの該当コードを書き換えれば良いのですよね？？
（Lila） 2015/11/26(木) 08:25
いったん、いろいろ書きこみましたが、こちらでの確認間違いもあったのでいったん消去しました。
Ｂブックの日付を２行目に変更して、そちらのコードを実行しました。 当方では、きちんと計算されて SHeet2 に %表示されています。
ですから、データが、コードの合わないということなんでしょうねぇ？？
>>サブプロシジャを別に置くか、コードの一番上に置いて、そのほかの該当コードを書き換えれば良いのですよね？？
はい。一度、そうして試してみてください。
（β） 2015/11/26(木) 08:48
（Lila） 2015/11/26(木) 08:57
数値の箇所は、シートの列や行の事を指していると思っているのですが、違うのでしょうか･･･？
度々申し訳ありませんが、ご教示のほどよろしくお願い致します。
【VBAコード】
Sub 故障率3()
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
.AutoFilterMode = False '念のためにオートフィルター解除
.UsedRange.Offset(3).AutoFilter
End With
MsgBox "処理が完了しました。"
End Sub
（Lila） 2016/03/03(木) 13:42
懐かしいコードですね。一応、そちらで使っていただいていたようで作者としてはうれしい限りですが すっかり忘却の彼方の、そのまた彼方です。
思い出せるかどうか、不安ですけど、ちょっとコードを追いかけてみます。 実際に動かせば解決は早いのでしょうけど、ブック等の環境も、もうすっかり消去しているので。
ところで、アップされた故障率3、ちょっとへんじゃないですか？ For j = mCol - 11 To 5 Step -12 '最終ブロックの先頭列からE列まで 12列単位で処理 この For にあたる Next が見当たらないですね？
それと、このとぴそのものが、長いというか文字数が大きくなっているので、たとえば編集等の操作ができなくなっていると思います。 このとぴを参照した形で、続編の新しいとぴを立ち上げられてはいかがでしょう。
（β） 2016/03/03(木) 16:57
長引くようであれば、↑でお願いした新しいトピでお願いしたいのですが、
With .Range(.Cells(5, j), .Cells(mRow, j + 5))
その前の '.Columns(j).Resize(, 6).Delete は、6か月分に縮小しているところで、そこはコメントアウトして削除スキップしていますが この With でくくった領域、6か月分だけですね。
With .Range(.Cells(5, j), .Cells(mRow, j + 11))
にすると、どうなりますか？
（β） 2016/03/03(木) 17:09
＞ 懐かしいコードですね。一応、そちらで使っていただいていたようで作者としてはうれしい限りですが
大変重宝しております＞＜
ありがとうございます。
NEXTは、UPした時に消してしまったのか、確かに無いですね＾＾；
でも、実際のブックの方にはちゃんとあるので、大丈夫です！
＞ With .Range(.Cells(5, j), .Cells(mRow, j + 11))
此処の数値は行の事ではなく、列の方だったのですね！
ありがとうございます^o^*
解決できました！
（Lila） 2016/03/04(金) 08:48
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.