| |
▼初心者 さん：
>《イメージ》
>【Sheet1】 → パターン仕訳け
>-------------------------------------
>種別 1. 2. 3. パターン 対象外
>A 1 あ →A の「あ」の行
>A 1 あ →A の「あ」の行
>A 1 い →A の 「い」の行
>B 1 1 う →B の 「う」の行
>B 1 S →B の「対象外」の行
>C 1 →C の「調査中」の行
'
Sub Try1()
Dim i As Long, n As Long, m As Long
Dim dic As Object '種別を調べるための箱を用意します。
Set dic = CreateObject("Scripting.Dictionary")
Dim r As Object
Dim v
Set r = Worksheets(1).[A1].CurrentRegion '表データを配列に入れる
v = Intersect(r, r.Offset(1)).Value '入れる（一行目は除く）
'(1) 種別の種類を調べる → A,B,C
For i = 1 To UBound(v)
If Not dic.Exists(v(i, 1)) Then
n = n + 1
dic(v(i, 1)) = n
End If
Next '以上で 種別 A(1), B(2), C(3) が完成()内は行番号
'(2) パターンの種類を調べる → 「あ」,「い」,「う」
Dim dic2 As Object
Set dic2 = CreateObject("Scripting.Dictionary")
m = 0
For i = 1 To UBound(v) '5列目を調べる
If Not IsEmpty(v(i, 5)) Then
If Not dic2.Exists(v(i, 5)) Then
m = m + 1
dic2(v(i, 5)) = m
End If
End If
Next
' パターンとしてはこれ以外に「対象外」「調査中」を追加。
Dim mout&, mcho&
m = m + 1
dic2("対象外") = m: mout = m
m = m + 1
dic2("調査中") = m: mcho = m
'(3) 以上が分ったら、
' 種別の数だけ大きい箱を用意する
' 箱の中に パターンの数だけの小さい箱を入れる
' そのパターン用の小さい箱のなかは 1. ｜ 2. ｜ 3. の仕切りを入れる
ReDim Ot(1 To n, 1 To m, 1 To 3)
' ┌────────────────┐
'n=1│種別A パターン 1. 2. 3. │
' │ 1 あ │
' │ 2 い │
' │ 3 う │
' │ 4 対象外 │
' │ 5 調査中 │
' └────────────────┘
'(4) もう一度Sheet1の表を上から順に読んでいって、データを仕分ける
Dim j As Long, x As Long
For i = 1 To UBound(v)
n = dic(v(i, 1))
If Not IsEmpty(v(i, 5)) Then
m = dic2(v(i, 5))
Else
If v(i, 6) = "S" Then
m = mout
Else
m = mcho
End If
End If
'[1.][2.][3.]列の値１を調べる（あれば配列要素位置に加算）
For j = 1 To 3
x = j + 1
If v(i, x) > 0 Then
Ot(n, m, j) = Ot(n, m, j) + v(i, x)
End If
Next
Next
'(5) Sheet2に 種別の数だけカード型データベースを発行する
Sheet2.Select
Sheet2.UsedRange.ClearContents
Dim a, b, c
Dim y As Long
y = 1
[A1:E1].Value = Split("種別 パターン 1. 2. 3.")
For Each a In dic.Keys()
y = y + 1
Cells(y, 1).Value = a
n = dic(a)
For Each b In dic2.Keys()
y = y + 1
Cells(y, 2).Value = b
m = dic2(b)
For j = 1 To 3
If Ot(n, m, j) > 0 Then
Cells(y, j + 2).Value = Ot(n, m, j)
End If
Next
Next
Next
End Sub
|
|
kanabun
- 14/7/13(日) 11:56 -
