[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『変則的な表の計算』（アユサン）
Sheet1の表は日々発生する、ﾗｲﾝ別の不良原因と不良数をまとめたデータです。 Sheet1の処理日2013年3月分だけの、各ﾗｲﾝの原因別の不良数をSheet2に抽出し
Sheet3にはSheet2で抽出され値を%で表したいと思います。%の分母は2013年3月分だけの 良品数+不良合計です。例えばﾗｲﾝAの分母は27、ﾗｲﾝBは6、ﾗｲﾝCは26、ﾗｲﾝDは 3月分だけなので15になります。マクロでご教示お願いします。 Windows 8、Excel2010です。
Sheet1 A B C D E F G H I J 1処理日 ﾗｲﾝ名 良品数 不良合計 原因1 不良数1 原因2 不良数2 原因3 不良数3 2 3/1 A 12 2 ｴﾝｼﾞﾝ 1 ｼｰﾄ 1 3 3/4 A 10 3 ｴﾝｼﾞﾝ 2 ﾌﾞﾚｰｷ 1 4 3/2 B 5 1 ｴﾝｼﾞﾝ 1 5 3/20 C 12 2 塗装 1 ﾌﾞﾚｰｷ 1 6 3/4 C 9 3 ｼｰﾄ 1 ｱｸｾﾙ 1 塗装 1 7 2/22 D 12 1 ﾌﾞﾚｰｷ 1 8 3/5 D 11 4 ｴﾝｼﾞﾝ 2 塗装 1 ｼｰﾄ 1
Sheet2
A B C D E F
1 2013/3 ｴﾝｼﾞﾝ ｼｰﾄ ﾌﾞﾚｰｷ 塗装 ｱｸｾﾙ
2 A 3 1 1
3 B 1
4 C 1 1 2 1
5 D 2 1 1
Sheet3
A
1 2013/3 ｴﾝｼﾞﾝ ｼｰﾄ ﾌﾞﾚｰｷ 塗装 ｱｸｾﾙ
2 A 11.1% 3.7% 3.7%
3 B 16.7%
4 C 3.8% 3.8% 7.7% 3.8%
5 D 13.3% 6.7% 6.7%
少し強引な力技になったけど。
Sub Sample()
Dim dicH As Object
Dim dicV As Object
Dim dicT As Object
Dim c As Range
Dim reason As String
Dim line As String
Dim v() As Variant
Dim yymm As String
Dim i As Long
Dim j As Long
Dim w As Variant
Dim bDate As Date
bDate = DateSerial(2013, 3, 1)
yymm = Format(bDate, "yyyymm") '指定年月
Set dicH = CreateObject("Scripting.Dictionary")
Set dicV = CreateObject("Scripting.Dictionary")
Set dicT = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
For Each c In .Offset(, 1) 'B列
If Not dicV.exists(c.Value) Then dicV(c.Value) = dicV.Count + 1
Next
For Each c In Union(.Offset(, 4), .Offset(, 6), .Offset(, 8)) 'E,G,I列
If Len(c.Value) > 0 And Not dicH.exists(c.Value) Then dicH(c.Value) = dicH.Count + 1
Next
ReDim v(1 To dicV.Count, 1 To dicH.Count)
For Each c In .Cells 'A列
If Format(c.Value, "yyyymm") = yymm Then
line = c.Offset(, 1).Value
dicT(line) = dicT(line) + WorksheetFunction.Sum(c.Offset(, 2).Resize(, 2))
For j = 5 To 9 Step 2
reason = c.Offset(, j - 1).Value
If Len(reason) > 0 Then
v(dicV(line), dicH(reason)) = v(dicV(line), dicH(reason)) + c.Offset(, j).Value
End If
Next
End If
Next
End With
End With
With Sheets("Sheet2")
.Cells.ClearContents
.Range("A1").Value = bDate
.Range("A1").NumberFormatLocal = "yyyy""年""m""月"";@"
.Range("A2").Resize(dicV.Count).Value = WorksheetFunction.Transpose(dicV.keys)
.Range("B1").Resize(, dicH.Count).Value = dicH.keys
.Range("B2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
w = .Range("A1").CurrentRegion.Value
End With
For i = 2 To UBound(w, 1)
For j = 2 To UBound(w, 2)
If Len(w(i, j)) > 0 Then w(i, j) = w(i, j) / dicT(w(i, 1))
Next
Next
With Sheets("Sheet3")
With .Range("A1").Resize(UBound(w, 1), UBound(w, 2))
.Value = w
.NumberFormatLocal = "0.0%"
End With
.Range("A1").NumberFormatLocal = "yyyy""年""m""月"";@"
End With
End Sub
(ぶらっと)
展開先の１行目タイトルの順番が、アップされたイメージとはちょっと違う順番だったので変更。 また、転記枠確定のためのループが２つになっていたのを集約。 ついでに、現在は原因3までだけど、原因4、原因5、といったものが追加されていっても対応。
Sub Sample2()
Dim dicH As Object
Dim dicV As Object
Dim dicT As Object
Dim c As Range
Dim reason As String
Dim line As String
Dim v() As Variant
Dim yymm As String
Dim i As Long
Dim j As Long
Dim w As Variant
Dim bDate As Date
Dim mCol As Long
bDate = DateSerial(2013, 3, 1)
yymm = Format(bDate, "yyyymm") '指定年月
Set dicH = CreateObject("Scripting.Dictionary")
Set dicV = CreateObject("Scripting.Dictionary")
Set dicT = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
mCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
For Each c In .Cells
If Not dicV.exists(c.Offset(, 1).Value) Then dicV(c.Offset(, 1).Value) = dicV.Count + 1 'B列
For j = 5 To mCol Step 2 'E列以降
reason = c.Offset(, j - 1).Value
If Len(reason) > 0 And Not dicH.exists(reason) Then dicH(reason) = dicH.Count + 1
Next
Next
ReDim v(1 To dicV.Count, 1 To dicH.Count)
For Each c In .Cells
If Format(c.Value, "yyyymm") = yymm Then
line = c.Offset(, 1).Value
dicT(line) = dicT(line) + WorksheetFunction.Sum(c.Offset(, 2).Resize(, 2))
For j = 5 To mCol Step 2
reason = c.Offset(, j - 1).Value
If Len(reason) > 0 Then
v(dicV(line), dicH(reason)) = v(dicV(line), dicH(reason)) + Val(c.Offset(, j).Value)
End If
Next
End If
Next
End With
End With
With Sheets("Sheet2")
.Cells.ClearContents
.Range("A1").Value = bDate
.Range("A1").NumberFormatLocal = "yyyy""年""m""月"";@"
.Range("A2").Resize(dicV.Count).Value = WorksheetFunction.Transpose(dicV.keys)
.Range("B1").Resize(, dicH.Count).Value = dicH.keys
.Range("B2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
w = .Range("A1").CurrentRegion.Value
End With
For i = 2 To UBound(w, 1)
For j = 2 To UBound(w, 2)
If Len(w(i, j)) > 0 Then w(i, j) = w(i, j) / dicT(w(i, 1))
Next
Next
With Sheets("Sheet3")
.Cells.ClearContents
With .Range("A1").Resize(UBound(w, 1), UBound(w, 2))
.Value = w
.NumberFormatLocal = "0.0%"
End With
.Range("A1").NumberFormatLocal = "yyyy""年""m""月"";@"
End With
End Sub
(ぶらっと)
ぶらっとさん、ありがとうございました。 今から、仕事です。帰ってからゆっくり確認させていただきます。 まずはお礼まで。 (アユサン)
時間があったので、私も整理してみました。 検索対象月を、Sheet2 の [A1]から取得しています。 従って、ここに表示はともかく Monthの取得できる、日付データの入っているとの条件です。 なを、原因別項目数を、max 10 で設定していますが、それ以上の場合は、w の設定変更が必要になります。
Sub Test()
Dim i&, j&, m&, n&, r&, c&, v, w
Dim D As Object, Mon&, Sa$, Sb$
Set D = CreateObject("scripting.dictionary")
'準備
v = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Value '元Data
With Sheets("Sheet2")
ReDim w(1 To UBound(v), 1 To 11) '展開用配列準備(原因別 Max 10項目)
w(1, 1) = .Cells(1, 1).Value
Mon = Month(w(1, 1)) '検索月
End With
'内部処理
m = 1: n = 1 '初期値
For i = 2 To UBound(v)
If Month(v(i, 1)) = Mon Then '3月
Sa = v(i, 2)
If Not D.exists(Sa) Then
m = m + 1
D(Sa) = m: w(m, 1) = Sa
End If
D("To" & Sa) = D("To" & Sa) + v(i, 3) + v(i, 4) '品数Count
For j = 5 To UBound(v, 2) Step 2
If Not IsEmpty(v(i, j)) Then
Sb = v(i, j)
If Not D.exists(Sb) Then
n = n + 1
D(Sb) = n: w(1, n) = Sb
End If
r = D(Sa): c = D(Sb)
w(r, c) = w(r, c) + v(i, j + 1) '原因別件数Count
End If
Next
End If
Next
'展開
With Sheets("Sheet2")
.Cells.ClearContents
.Cells(1, 1).Resize(m, n).Value = w
End With
For i = 2 To UBound(w)
For j = 2 To UBound(w, 2)
If Not IsEmpty(w(i, j)) Then
w(i, j) = w(i, j) / D("To" & w(i, 1)) '%処理
End If
Next
Next
With Sheets("Sheet3")
.Cells.ClearContents
.Cells(1, 1).Resize(m, n).Value = w
End With
Set D = Nothing
End Sub
(暇人)
ぶらっとさん、暇人さんありがとうございました。お返事遅れて申し訳ありません。 確認させていただき、どちらもうまくいきました。 ぶらっとさんに質問なんですが、月が変わる度、更新していきたいたいのですが、 その都度、Sample2の、bDate = DateSerial(2013, 3, 1)を替えるより、 Sheet4のA1に指定月日を入力するようにしたほうが良いのではないかとおもいます。 その方法をご指導おねがいします。
bDate = Sheets("Sheet4").Range("A1").Value
(ぶらっと)
ぶらっとさん、わかりました。ありがとうございました。 （アユサン）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.