[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『条件が増えて旨くいきません3』（あちゃこ）
Sheet1の表から型式別、名前別に不良数と不良率(不良/受入)をSheet2の表に転記。 不良率はSheet2の20行目の表にそれぞれマクロで埋めたいです。条件は以下です。
条件①A列 営業所Wのみ 条件②E列 年月がSheet2 A1に示す年月分だけ 条件③計算結果が0のときは空白に
下のほうに今回に類似した質問させていただいたものを添付します。 できればこの式を活用したいのでしすが。ご指導よろしくお願いします。
Sheet1 Sheet2
A B C D E F A B C D E F
1 営業所 不良 型式 名前 年月 受入 1 2012/1 森田 石田 山本 坂本 鈴木
2 W 1 20-1 森田 1/5 30 2 20-1
3 S 3 20-3 石田 1/6 40 3 20-2
4 W 2 20-5 山本 1/7 20 4 20-3
5 S 1 20-3 石田 2/1 30 5 20-4
6 W 4 20-2 坂本 1/7 70 6 20-5
7 W 3 20-2 坂本 1/9 30
8 E 4 20-4 鈴木 1/10 40
20 森田 石田 山本 坂本 鈴木
21 20-1
22 20-2
23 20-3
24 20-4
25 20-5
『条件が増えて旨くいきません2』（あちゃこ）
Sheet1のA列の営業所Wの不良数(B列受入-C列合格)をSheet2に転記し、 不良率(B列受入-C列合格)/B列受入)をSheet3に転記したいと思っています。 なお 下記に示す、Sub test3()は最初に学んだもので、馴染みやすく、ﾚｲｱｳﾄ等 が違いますが、これを活用したいと思っています。ご指導よろしくお願いします。
Sheet1 Sheet2
A B C D E A B C D E F
1 営業所 受入 合格 型式 名前 森田 石田 山本 坂本 鈴木
2 W 20 19 20-1 森田 20-1
3 S 30 28 20-3 石田 20-2
4 W 20 20 20-5 山本 20-3
5 S 10 9 20-3 石田 20-4
6 W 40 37 20-2 坂本 20-5
7 W 30 29 20-2 坂本
8 E 40 46 20-4 鈴木
Sheet3
A B C D E F
1 森田 石田 山本 坂本 鈴木
2 20-1
3 20-2
4 20-3
5 20-4
6 20-5
Sub test5()
Dim tbl As Variant
Dim buf As String
Dim i As Long
Dim j As Long
Dim wk As Variant
Dim num As Variant
Dim myTime As Double
myTime = Timer
tbl = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tbl, 1)
If tbl(i, 1) = "W" Then
buf = tbl(i, 4) & vbTab & tbl(i, 5)
If Not .exists(buf) Then .Item(buf) = Array(0, 0)
wk = .Item(buf)
wk(0) = wk(0) + tbl(i, 2)
wk(1) = wk(1) + tbl(i, 3)
.Item(buf) = wk
End If
Next i
With Worksheets("Sheet2").Range("A1").CurrentRegion
tbl = .Value
End With
For i = 2 To UBound(tbl, 1)
For j = 2 To UBound(tbl, 2)
buf = tbl(i, 1) & vbTab & tbl(1, j)
If .exists(buf) Then
num = .Item(buf)(0) - .Item(buf)(1)
If num <> 0 Then tbl(i, j) = num
End If
Next j
Next i
Worksheets("Sheet2").Range("A1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
With Worksheets("Sheet3").Range("A1").CurrentRegion
tbl = .Value
End With
For i = 2 To UBound(tbl, 1)
For j = 2 To UBound(tbl, 2)
buf = tbl(i, 1) & vbTab & tbl(1, j)
If .exists(buf) Then
num = CDec((.Item(buf)(0) - .Item(buf)(1)) / .Item(buf)(0))
If .Item(buf)(0) <> 0 And num <> 0 Then tbl(i, j) = num
End If
Next j
Next i
End With
Worksheets("Sheet3").Range("A1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
MsgBox Format(Timer - myTime, "#,##0.00") & "秒かかりました。"
End Sub
条件として、 1、Sheet1の「年月」はシリアル値を書式で「m/d」にして在る 2、Sheet2のA1の年月はシリアル値を書式で「yyyy/m」にして在る
Option Explicit
Sub test_6()
Dim tbl As Variant
Dim tbl2 As Variant
Dim buf As String
Dim i As Long
Dim j As Long
Dim wk As Variant
Dim vntDate As Variant
Dim myTime As Double
myTime = Timer
'Sheet1のA1から連接する範囲を配列としてVariant型変数tblに取得
tbl = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
'Sheet2のA1の値を取得
vntDate = Worksheets("Sheet2").Range("A1").Value
'Dictionryオブジェクトに就いて
With CreateObject("Scripting.Dictionary")
'Sheet1のList2行目～最終行まで繰り返す
For i = 2 To UBound(tbl, 1)
'「営業所」が「W」なら
If tbl(i, 1) = "W" Then
'「年月」の値とSheet2のA1の値が同じなら
If Format(tbl(i, 5), "yyyymm") = Format(vntDate, "yyyymm") Then
'「型式」と「名前」をTab文字で連結
buf = tbl(i, 3) & vbTab & tbl(i, 4)
'連結した文字列がDictionaryにKeyとして無いなら
If Not .Exists(buf) Then
'空の配列を連結文字列をKeyとしたItemに代入
.Item(buf) = Array(0, 0)
End If
'連結文字列をKeyとしたItemを配列として変数wkに書き戻す
wk = .Item(buf)
'書き戻した配列の0列に不良数を加算
wk(0) = wk(0) + tbl(i, 2)
'書き戻した配列の1列に受入数を加算
wk(1) = wk(1) + tbl(i, 6)
'連結文字列をKeyとしたItemに配列を代入
.Item(buf) = wk
End If
End If
Next i
'Sheet2のA1から連接する範囲を配列としてVariant型変数tblに取得
tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
'Sheet2のA20から始まる不良率表の出力配列を確保
tbl2 = tbl
'不良数の表の型式先頭～最終行迄繰り返し
For i = 2 To UBound(tbl, 1)
'不良数の表の名前先頭～最終列迄繰り返し
For j = 2 To UBound(tbl, 2)
'不良数の表の「型式」と「名前」をTab文字で連結して
buf = tbl(i, 1) & vbTab & tbl(1, j)
'Dictionaryに連結文字列がKeyとして有ったら
If .Exists(buf) Then
'連結文字列をKeyとしたItemを配列として変数wkに書き戻す
wk = .Item(buf)
'不良数を不良数の表に代入
tbl(i, j) = wk(0)
'受入数が0で無いなら（0の除算を避ける）
If wk(1) > 0 Then
'不良率を計算して不良率の表に代入
tbl2(i, j) = wk(0) / wk(1) * 100
End If
End If
Next j
Next i
End With
'結果を出力
With Worksheets("Sheet2")
'不良数の表を出力
.Range("A1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
'不良率の表を出力
.Range("A20").Resize(UBound(tbl2, 1), UBound(tbl2, 2)).Value = tbl2
End With
MsgBox Format(Timer - myTime, "#,##0.00") & "秒かかりました。"
End Sub
(Bun)
Bunさん、丁寧な解説を入ていただき今後に大いに役立ちます。感謝しています。 ありがとうございました。
新たな問題が出てきました。不良数は問題ないのですが、不良率のほうが空白に なります。 原因を調べると、Sheet1のデータが変則的なデータになっていていました。 しっかり見ていたらよかったのですが申し訳ありません。
見直したデータは以下で、1行目から8行目の受入は0になっていて、9行目以降に G列の受入NO,に等しく入っています。不良率の分母はC列型式に対する受入数です。 申し訳ありませんがもう一度ご指導お願いします。
Sheet1
A B C D E F G
1 営業所 不良 型式 名前 年月 受入 受入NO,
2 W 1 20-1 森田 1/5 0 1
3 S 3 20-3 石田 1/6 0 2
4 W 2 20-5 山本 1/7 0 3
5 S 1 20-3 石田 2/1 0 4
6 W 4 20-2 坂本 1/7 0 5
7 W 3 20-2 坂本 1/9 0 6
8 E 4 20-4 鈴木 1/10 0 7
9 W 0 20-1 OK 1/5 30 1 10 S 0 20-3 OE 1/6 40 2 11 W 0 20-5 OK 1/6 20 3 12 S 0 20-3 OK 2/1 30 4 13 W 0 20-2 OK 1/7 70 5 14 W 0 20-2 OK 1/9 30 6 15 E 0 20-4 OK 1/10 40 7 （あちゃこ）
幾つかの質問等を見て、あちゃこさんが必至でマクロを作ろうしているは善く解るのですが？ 先ず自分が扱うデータを善く理解しましょう 理解が出来ていないので、質問する時も其の部分の説明が上手く行かないのでは？
今回の新しく出て来た事実で、もう少し深く説明をして頂きたいのですが？ この表の中の「受入No,」とは何ですか？ 「受入No,」は必ず（この表で言えば、2行目の1と9行目の1）対応するのでしょうか？ 他に全然関係無いレコードに1が在るのでしょうか？ また、「名前」フィールドに「OK」と書かれて居るのは何故でしょうか？
此れを聞くのは、この表の様なでは、どの様な形でコードに組み込むかは解りませんが 事前集計が必要に成って来ると思いますので、その場合の当てにするKeyをどうするか鍵に成ります
(Bun)
変則的なデータで戸惑っています。 理解力が乏しいうえに説明が下手でご迷惑をかけております。 以後、よく理解のしたうえで質問させていただきます。申し訳ありませんでした。
受入No,とはその商品名とお考えください。 受入No,は必ず2行目の1と9行目の1のように必ず対応します。 全然関係無いレコードに1が入ることはありません。
「名前」フィールドに「OK」は特に意味は意味は無いものと思われ、空白とお考え くだい。 型式ごとの受入数を事前計算が必要になってきますか？再度ご指導お願いします。 （あちゃこ）
色々な方法、考え方が有ると思いますが？ 今回、少しズボラをさせて頂きます
先にUpしたコードが今回の部分以外はOKとすれば （実際にOKかどうかは解りませんが？） 成るべく前のコードを弄りたく在りません（前のコードの中に組み込む事も出来るでしょうが？） 其処で、別なプロシージャを作り、此処でOK（10行目がOEに成って居るのが気に成りますが？）を 名前に置き換えてしまえば善いのではないかと考えました（そうすれば前のコードが其のまま使える） 出来たプロシージャを前のコードから呼び出せれば万歳と言う事です
Option Explicit
Sub test_7()
Dim tbl As Variant
Dim tbl2 As Variant
Dim buf As String
Dim i As Long
Dim j As Long
Dim wk As Variant
Dim vntDate As Variant
Dim myTime As Double
myTime = Timer
'Sheet1のA1から連接する範囲を配列としてVariant型変数tblに取得
tbl = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
'★名前フィールドの「OK」を名前に変換（Sub DataConvの呼び出し）
DataConv tbl
'Sheet2のA1の値を取得
vntDate = Worksheets("Sheet2").Range("A1").Value
'Dictionryオブジェクトに就いて
With CreateObject("Scripting.Dictionary")
'Sheet1のList2行目～最終行まで繰り返す
For i = 2 To UBound(tbl, 1)
'「営業所」が「W」なら
If tbl(i, 1) = "W" Then
'「年月」の値とSheet2のA1の値が同じなら
If Format(tbl(i, 5), "yyyymm") = Format(vntDate, "yyyymm") Then
'「型式」と「名前」をTab文字で連結
buf = tbl(i, 3) & vbTab & tbl(i, 4)
'連結した文字列がDictionaryにKeyとして無いなら
If Not .Exists(buf) Then
'空の配列を連結文字列をKeyとしたItemに代入
.Item(buf) = Array(0, 0)
End If
'連結文字列をKeyとしたItemを配列として変数wkに書き戻す
wk = .Item(buf)
'書き戻した配列の0列に不良数を加算
wk(0) = wk(0) + tbl(i, 2)
'書き戻した配列の1列に受入数を加算
wk(1) = wk(1) + tbl(i, 6)
'連結文字列をKeyとしたItemに配列を代入
.Item(buf) = wk
End If
End If
Next i
'Sheet2のA1から連接する範囲を配列としてVariant型変数tblに取得
tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
'Sheet2のA20から始まる不良率表の出力配列を確保
tbl2 = tbl
'不良数の表の型式先頭～最終行迄繰り返し
For i = 2 To UBound(tbl, 1)
'不良数の表の名前先頭～最終列迄繰り返し
For j = 2 To UBound(tbl, 2)
'不良数の表の「型式」と「名前」をTab文字で連結して
buf = tbl(i, 1) & vbTab & tbl(1, j)
'Dictionaryに連結文字列がKeyとして有ったら
If .Exists(buf) Then
'連結文字列をKeyとしたItemを配列として変数wkに書き戻す
wk = .Item(buf)
'不良数を不良数の表に代入
tbl(i, j) = wk(0)
'受入数が0で無いなら（0の除算を避ける）
If wk(1) > 0 Then
'不良率を計算して不良率の表に代入
tbl2(i, j) = wk(0) / wk(1) * 100
End If
End If
Next j
Next i
End With
'結果を出力
With Worksheets("Sheet2")
'不良数の表を出力
.Range("A1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
'不良率の表を出力
tbl2(1, 1) = Empty '★不良李表A1の日付を消去
.Range("A20").Resize(UBound(tbl2, 1), UBound(tbl2, 2)).Value = tbl2
End With
MsgBox Format(Timer - myTime, "#,##0.00") & "秒かかりました。"
End Sub
Private Sub DataConv(vntList As Variant)
'「OK」を名前に置き換え
Dim i As Long
Dim j As Long
Dim dicIndex As Object
Dim lngHold() As Long
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'Sheet1のListの2行目～最終行迄繰り返し
For i = 2 To UBound(vntList, 1)
'名前フィールドが「OK」で無ければ
If StrComp(vntList(i, 4), "OK", vbTextCompare) <> 0 Then
'Dictionaryに「受入NO,」の登録が無ければ
If Not .Exists(vntList(i, 7)) Then
'「受入NO,」をKeyとして「名前」を登録
.Item(vntList(i, 7)) = vntList(i, 4)
End If
'名前フィールドが「OK」なら
Else
'Dictionaryに「受入NO,」の登録が有れば
If .Exists(vntList(i, 7)) Then
'「OK」を「名前」に置換
vntList(i, 4) = .Item(vntList(i, 7))
'Dictionaryに「受入NO,」の登録が無ければ
Else
'保留を記録する配列を確保
'(名前が有る行より前に「OK」の在る行が有った場合の対処）
j = j + 1
ReDim Preserve lngHold(1 To j)
lngHold(j) = i
End If
End If
Next i
'保留が有った場合
If j >= 0 Then
'再度Dictionaryに問い合わせ
For i = 1 To j
'Dictionaryに「受入NO,」の登録が有れば
If .Exists(vntList(lngHold(i), 7)) Then
'「OK」を「名前」に置換
vntList(lngHold(i), 4) = .Item(vntList(lngHold(i), 7))
End If
Next i
End If
End With
'Dictionaryオブジェクトを破棄
Set dicIndex = Nothing
End Sub
(Bun)
Bunさん、うまくいきました。説明が足らず済みませんでした。 ありがとうございました。 (あちゃこ)
今回、元々私のコードを直して居る訳ではないので 殆ど其のままの形で直して居ます 其処で、幾つか気に成る注意点に気が付きましたので書いて起きます
1、結果の出力用の配列を
'Sheet2のA1から連接する範囲を配列としてVariant型変数tblに取得
tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
と言う形で範囲を配列に取得し、其れを結果出力用配列に使って居ます 何回か違うデータを使ってこのマクロ使った場合、 例えば、Upされているサンプルデータで実行した場合、不良表が 森田：20-1が1 山本：20-5が2 坂本：20-2が7 に成ると思います しかし、前回実行時に、もし石田：20-2に1と言う結果が有ったとすると これが消去されていませんので 森田：20-1が1 山本：20-5が2 坂本：20-2が7 石田：20-2が1 と言う結果に成ってしまいます 此れを防ぐには、上記のtbl取得前に範囲を消去して置いた方が善い様な気がします 消去を行うなら以下の様にすれば善いかと思います
'★Sheet2のA1から連接する範囲に就いて
With Worksheets("Sheet2").Range("A1")
'★範囲を消去
Application.Intersect(.CurrentRegion, .CurrentRegion.Offset(1, 1)).ClearContents
'配列としてVariant型変数tblに取得
tbl = .CurrentRegion.Value
End With
'Sheet2のA20から始まる不良率表の出力配列を確保
2、今回のマクロでは、不良表に対する不良率表で在るので、
両表の列見出し（名前）と行見出し（型式）は全く同じと考えましたので
'Sheet2のA20から始まる不良率表の出力配列を確保
tbl2 = tbl
として、配列をCopyして使って居ます、因って両表の列見出し（名前）と行見出し（型式）を
両表で代えても無駄に成ります
3、元々のマクロがデータ取得にCurrentRegionを使用して居ますので
Sheet2に於いて、例えば、不良表の上下とか左にコメントを入れる様な場合は
必ず、不良表、不良率表の間、回りは必ず1行以上または1列以上開けて開けて下さい
そうしないと、コメント部までデータとして配列に取り込まれますので気を付けて下さい
(Bun)
Bunさん、返信遅れてしまいました。 注意3点よくわかりました。ありがとうございました。 (あちゃこ)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.