[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『同じ色のセルの数値を抽出し，最小値，最大値，平均値を出したい』（マクロす）
Excel2010，Windows7を使用しています。 マクロの仕組みも理解せずに，必要に迫られたため，いろんなサイトの情報をかき集め，試行錯誤の末なんとか以下の2つはできました。
1.同じ色のセルの数を数える
Function CountColor(計算範囲, 条件色セル)
CountColor = 0
For y = 1 To 計算範囲.Columns.Count
For x = 1 To 計算範囲.Rows.Count
If 計算範囲.Rows(x).Columns(y).Interior.color = 条件色セル.Interior.color Then
CountColor = CountColor + 1
End If
Next
Next
End Function
2.同じ色のセルの数値を合計する
Function SumColor(計算範囲, 条件色セル)
SumColor = 0
For y = 1 To 計算範囲.Columns.Count
For x = 1 To 計算範囲.Rows.Count
If 計算範囲.Rows(x).Columns(y).Interior.color = 条件色セル.Interior.color Then
SumColor = SumColor + 計算範囲.Rows(x).Columns(y)
End If
Next
Next
End Function
(例) ABC 1 5(赤) 7(青) 9(赤) 2 4(赤) 3(赤) 6(黄) 3 8(青) 5(黄) 2(赤) 4 5 各色の数 6 5(赤) 7 2(青) 8 2(黄) 9 10各色の合計 11 23(赤) 12 15(青) 13 11(黄)
※()はセルの色，A6には【=CountColor(A1:C3,A6)】，A11には【=SumColor(A1:C3,A11)】を入力すると値がでる（青，黄も同様に）。
ところが，標記の3つのやり方が解らず，挫折してしまいました。 MIN，MAX，AVERAGEを使えば良いようなので，MINColor，MAXColor，AVERAGEColor…っと，やってみましたがダメでした。根本的に考え方が間違ってますか？ 1.2.も含め，もっと良いやり方がありましたら，ご教示くださいますよう，お願い致します。
各種数値取得を｢オールインワン｣にしたコード案。
例としてA1:D5 に数値を記入して様々な色をつけておく。 J1 を検索すべき色にしておいて Test を実行してみて。
標準モジュール
Option Explicit
Type ColorInfo
max As Double
min As Double
ave As Double
tot As Double
cnt As Long
End Type
Sub Test()
Dim ans As ColorInfo
ans = getInfo(Range("A1:D5"), Range("J1"))
MsgBox "合計:" & ans.tot & vbLf & _
"件数:" & ans.cnt & vbLf & _
"最大:" & ans.max & vbLf & _
"最小:" & ans.min & vbLf & _
"平均:" & ans.ave
End Sub
Function getInfo(計算範囲 As Range, 条件色セル As Range) As ColorInfo
Dim c As Range
Dim flag As Boolean
flag = True
For Each c In 計算範囲.Cells '列指定、行指定にも対応
If c.Interior.Color = 条件色セル.Interior.Color Then
getInfo.cnt = getInfo.cnt + 1
getInfo.tot = getInfo.tot + c.Value
If c.Value > getInfo.max Then getInfo.max = c.Value
If flag Then
getInfo.min = c.Value
flag = False
Else
If c.Value < getInfo.min Then getInfo.min = c.Value
End If
End If
Next
If getInfo.cnt > 0 Then getInfo.ave = getInfo.tot / getInfo.cnt
End Function
(ぶらっと)
↑ あっ！！！！
ＵＤＦだった！！！ ごめん。
Type利用をやめて、アップした、それぞれのものだけを返すようにすれば、いけるね。 それぞれ、別のプロシジャにわけてもいいし、オールインワンにしたまま、使うときに =GetColorInfo(領域,指定カラーセル,"Min") とか、=GetColorInfo(領域,指定カラーセル,"Average") とか。
Function getColorInfo(計算範囲 As Range, 条件色セル As Range, 条件タイプ As String) As Double
Dim c As Range
Dim flag As Boolean
Dim max As Double
Dim min As Double
Dim ave As Double
Dim tot As Double
Dim cnt As Long
flag = True
For Each c In 計算範囲.Cells '列指定、行指定にも対応
If c.Interior.Color = 条件色セル.Interior.Color Then
cnt = cnt + 1
tot = tot + c.Value
If c.Value > max Then max = c.Value
If flag Then
min = c.Value
flag = False
Else
If c.Value < min Then min = c.Value
End If
End If
Next
If cnt > 0 Then ave = tot / cnt
Select Case LCase(条件タイプ)
Case "min": getColorInfo = min
Case "max": getColorInfo = max
Case "average": getColorInfo = ave
Case "total": getColorInfo = tot
Case "count": getColorInfo = cnt
End Select
End Function
第3引数は "Max","Min","Average","Total","Count" のいずれか。大文字、小文字を問わない。
注）この手のセル書式を判定するもののネックは、たとえ、プロシジャの先頭に Applicatio.Volatile 記述をしても 書式（色）が変更されただけでは再計算されないということ。留意してね。
(ぶらっと)
Public Function SumC(Wr As Range, Wc As Range) As Long '合計：検索範囲,色セル
Application.Volatile
SumC = Application.Sum(GetA(Wr, Wc))
End Function
Public Function CountC(Wr As Range, Wc As Range) As Long 'カウント：検索範囲,色セル
Application.Volatile
CountC = Application.CountA(GetA(Wr, Wc))
End Function
Public Function MaxC(Wr As Range, Wc As Range) As Long '最大：検索範囲,色セル
Application.Volatile
MaxC = Application.Max(GetA(Wr, Wc))
End Function
Public Function MinC(Wr As Range, Wc As Range) As Long '最小：検索範囲,色セル
Application.Volatile
MinC = Application.Min(GetA(Wr, Wc))
End Function
Public Function AverageC(Wr As Range, Wc As Range) As Long '平均：検索範囲,色セル
Application.Volatile
AverageC = Application.Average(GetA(Wr, Wc))
End Function
''---------------------------------------------/*Wrの範囲でWcのセルと同じ色のセル範囲を戻す
Private Function GetA(Wr As Range, Wc As Range) As Range
Dim Myo As Range, Tgr As Range
For Each Myo In Wr
If Myo.Interior.Color = Wc.Interior.Color Then
If GetA Is Nothing Then
Set GetA = Myo
Else
Set GetA = Union(GetA, Myo)
End If
End If
Next
End Function
（Cod）
ぶらっとさん，お早うございます。できました！ 昨晩，早速の回答を頂いていたのにお返事が遅くなり，申し訳ありません。 実は，計算結果を一覧表という形で整理する必要があったので，頂いた回答をアレンジして何とかしようと 試みるも挫折し，MsgBoxで表示されたものを手打ちで一覧表に入力しました(笑)。
いやぁ～，でも今回はデータ数が比較的少なかったので，力技でなんとかなりましたが，データ数は多い時 で500～1000， 色の種別は15色にもなる時があるので，今朝の回答の方法は非常に助かります！！
確かにデータがあるセルの色をあとから変更すると，変更直後は再計算されるみたいだけど，元に戻すなど の操作をすると再計算されないのですね…いろいろ調べた結果，これについては色を変更するなどの作業を した最後の最後にAlt＋Ctrl＋F9押すことで強制的に再計算させる！ことで対応することにします。 うっかり忘れちゃったらアウトだけど(^_^;)
(マクロす，改め，がんバルキリー)
Codさん，お早うございます。 ぶらっとさんへのお礼を書込んでいる間に回答を頂いたようです。 Codさんの方法もできました！お二人とも素晴らしい！
Codさん，最後に一つ質問なのですが，AverageCの小数点以下の制御はどこで変更させられますでしょうか？ （小数点第2位や第3位で四捨五入，あるいは，切捨てにするなど）。 重ね重ね申し訳ありませんが，よろしくお願いいたします。
(マクロす，改め，がんバルキリー)
Public Function AverageC(Wr As Range, Wc As Range) As Double '平均：検索範囲,色セル
Dim W1 As Double, W2 As Double
Application.Volatile
W1 = Application.Average(GetA(Wr, Wc))
' W2 = Application.Round(W1, 2) 'ここで四捨五入
' W2 = Application.RoundDown(W1, 2) 'ここで切捨て
W2 = Application.RoundUp(W1, 2) 'ここで切あげ
AverageC = Format(W2, "0.00") '書式の指定
End Function
（Cod）
コードによる一括処理のサンプルです。
一応、検索範囲は、[B2:G11] 60Cell の設定で、結果を、[A20] 以降に一括表示します。
Sub Test()
Dim i&, j&, r As Range, v, w, x, S
Dim D As Object, n&, m&
Set D = CreateObject("scripting.dictionary")
n = 8
S = Split("Connt,Sum,Min,Max,Ave", ",")
ReDim v(1 To 5, 1 To 20) 'Max 20色
For j = 0 To 4
v(j + 1, 1) = S(j)
Next
m = 1
Range("a20:q20").Interior.Color = xlNone
For Each r In Range("b2:g11") '検索範囲 任意設定
x = r.Interior.Color
If Not D.exists(x) Then
m = m + 1
D(x) = m
Cells(20, m).Interior.Color = x
v(3, m) = 1000: v(4, m) = 0
End If
n = D(x)
v(1, n) = v(1, n) + 1 'Count
v(2, n) = v(2, n) + r.Value 'Sum
If r.Value < v(3, n) Then v(3, n) = r.Value 'Min
If r.Value > v(4, n) Then v(4, n) = r.Value 'Max
v(5, n) = Format(v(2, n) / v(1, n), ".00") 'Ave
Next
Cells(21, 1).Resize(5, 20).Value = v
Set D = Nothing
End Sub
(暇人)
Codさん，早速の回答ありがとうございます。 VBAの変数のデータ型であるlongやDoubleが関係していたんですね。って，この程度も解らずにVBAに取り組んでます(^_^;)
さて，ご教示頂いたマクロを早速貼り付けてみましたが・・・四捨五入や切捨ての切り替えはどうすれば良いのでしょうか？ 例えば，A1:D5 にデータがあり，A8のセルを検索すべき色にしておいて，B8に平均を表示させたい場合， B8に =AverageC(A1:D5,A8) と入力すると小数点第3位で切あげされた結果がでます。B8への入力式に何か加えれば， その他（四捨五入や切捨て，桁数）のことを指定することができるのですか？
と，ここまで書いて，ふと思ったこと。 実は私が貼り付けた場所は，前回のコードの Public Function AverageC(Wr As Range, Wc As Range) As Long '平均：検索範囲,色セル
Application.Volatile
AverageC = Application.Average(GetA(Wr, Wc))
End Function
を削除して，単純に2回目に頂いたコード
Public Function AverageC(Wr As Range, Wc As Range) As Double '平均：検索範囲,色セル
Dim W1 As Double, W2 As Double
Application.Volatile
W1 = Application.Average(GetA(Wr, Wc))
' W2 = Application.Round(W1, 2) 'ここで四捨五入
' W2 = Application.RoundDown(W1, 2) 'ここで切捨て
W2 = Application.RoundUp(W1, 2) 'ここで切あげ
AverageC = Format(W2, "0.00") '書式の指定
End Function
を挿入しました。 でも，これって，その都度，'以下のコメント行を調整（必要な行を外に出して他は削除，桁数は"0.00"の0の数を変える）などして， その時の目的にあった関数のコードにしてから組み込めば良い！って，ことだったんですよね。多分？違います(^_^;) もし，この解釈で合っているようでしたら，お返事は要りません。有難うございました。
(マクロす，改め，がんバルキリー)
暇人さん，こんにちは。 またまた，Codさんへのお礼を書込んでいる間に回答を頂いたようです。遅筆ですみません(苦笑) 暇人さんの方法もできました！
いやぁ～，皆さん素晴らしい！！ お三方のやり方を比較した結果，暇人さんの一括処理の方法が，今使っている一覧表の項目の配置に合うようにアレンジすれば， 今後の作業がすごい楽になる気がしました。 ちょっとトライしてみます。 また，行き詰まったら，ご教示願います。
(マクロす，改め，がんがんバルキリー)
提示コードに関しては、その判断で正解です。が
都度変更も辛いので仕様が明確になれば、桁と切り上げ・切り捨て・四捨五入と
編集書式をパラメーターにしておけば、もちろん可能です。
と、暇人さんから一括処理が出てますので、そちらの結果でまだ必要なら
言っていただければ考えてみますが。
（Cod）
エクセルの学校のみなさん，こんにちは。 これまでに，お三方から回答を頂き，なんとか求める形になってきたのですが…挫折しました。 整理したいのは，ある実験結果の各種データを集計し，一覧表を作成することです。 例を以下に示しますが，実験内容を晒すわけにいかないので（あ，いや決して怪しい実験ではない のですが)，判りやすいように某会社の某社員達によるバナナの叩き売りに置き換えてみました(^^) 某会社の山田，鈴木，佐藤，田中の4人が，越後屋，三河屋，大和屋，備前屋にランダムに出向し， バナナを何本売ったかを整理したいのです。
(例)バナナの叩き売り,個人別売り上げ集計および一覧表
A B C D E F
1 日数 越後屋 三河屋 大和屋 備前屋
2 1 3(黄) 7(青) 6(緑) 5(赤)
3 2 4(赤) 3(緑) 0(黄) 4(青)
4 3 4(青) 6(黄) 2(赤) 1(緑)
5 4 ―(青) 12(黄) 空白(無) 3(緑)
6 5 空白(無) 4(緑) 空白(無) 5(黄)
7
8 名前 日数 最少 最大 合計 平均
9 山田(赤) 3 2 5 11 3.6
10 鈴木(青) 3 4 7 15 5.0
11 佐藤(黄) 5 0 12 26 5.2
12 田中(緑) 5 1 6 17 3.4
※()はセルの色，入力範囲は[B2:E6]と[A9:A12]です。 これを，(暇人)さんが提案して下さったやり方で，結果を[B9:F12]に一括表示させたいのです。 （平均値は，小数点第2位を切捨て）。 ただし，[B2:E6]にデータを入力する際の決め事として， 1.店頭に立ったんだけど1本も売れなかった場合は0を入力（D3の大和屋に出向いた佐藤さん） 2.店頭に立ち「今日は30本売ったよ～」と報告してきたB5の鈴木さん…その後，店から電話があり 「今日来た奴は，バナナは売るが，女子店員と雑談ばかりしてて，真面目に仕事して無い！」とクレームが。 本人に確認したら，20本ぐらいは売れたと思うけど，その後はハッキリ数えてない。売れてんだからいいだろ！ と逆切れ。日頃の態度も悪かったことから，クビ！ 誰が行ったかを記録として残しておく必要があるため，セルの色は鈴木さんの青で塗る。 しかし，数値としては，本当の数が不明なため除外した！と，いった意味合いで「―（ダッシュ）」を入力。 0とはしない。つまり，平均値の計算の際には反映させたくない。15/4=3.7ではなくて，15/3=5.0となる。 【たとえが長くなりましたが，つまり異常値と判断して，集計から除外する。でも何のデータを除外したかを セルの色で判別できるようにしておきたいのです】 3.お店の人に，明日からは誰も来なくていいと言われた場合は空白とし，色も塗らない（B6,D5,D6）
以上，このような条件で入力するデータを一括処理させたいのですが…データの型が違ったりなのか， 何がどうのような仕組みなのか，全く理解できずにやってたら…パソコンがフリーズしてしまいました(泣) 急ぎませんので，どなたか手が空いている時にでも，ご教示頂ければ幸いですm(__)m
(マクロす，改め，がんがんバルキリー，改め，失速バルキリー)
要件誤解してたら指摘乞う。
Option Explicit
Enum ListItem
dummy
cnt
Min
Max
tot
ave
End Enum
Sub Sample()
Dim dicN As Object
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Set dicN = CreateObject("Scripting.Dictionary")
Set dicD = CreateObject("Scripting.Dictionary")
With Range("A8").CurrentRegion.Offset(1)
ReDim v(1 To .Rows.Count - 1, 1 To 5)
For Each c In .Columns(1).Resize(.Rows.Count - 1).Cells
dicN(c.Font.Color) = dicN.Count + 1
dicD(c.Font.Color) = False
Next
End With
With Range("A1").CurrentRegion.Offset(1)
For Each c In .Resize(.Rows.Count - 1)
If IsNumeric(c.Value) Then
myColor = c.Font.Color
If dicN.exists(myColor) Then
i = dicN(myColor)
v(i, cnt) = v(i, cnt) + 1
v(i, tot) = v(i, tot) + c.Value
If c.Value > v(i, Max) Then v(i, Max) = c.Value
If dicD(myColor) Then
If c.Value < v(i, Min) Then v(i, Min) = c.Value
Else
v(i, Min) = c.Value
dicD(myColor) = True
End If
End If
End If
Next
End With
For i = LBound(v, 1) To UBound(v, 1)
If v(i, cnt) > 0 Then v(i, ave) = WorksheetFunction.RoundDown(v(i, tot) / v(i, cnt), 1)
Next
Range("B9").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
(ぶらっと)
ぶらっとさん，こんにちは。 回答ありがとうございます。早いですね～。 早速実行させて頂きました。 が…鈴木さんの行にのみ数値がでてきて，その結果も違っているようです。 [B9:F12]の結果がこの前の前のコメントに記載した結果になると万々歳なのですが。。。
（実行結果）
A B C D E F
1 日数 越後屋 三河屋 大和屋 備前屋
2 1 3(黄) 7(青) 6(緑) 5(赤)
3 2 4(赤) 3(緑) 0(黄) 4(青)
4 3 4(青) 6(黄) 2(赤) 1(緑)
5 4 ―(青) 12(黄) 空白(無) 3(緑)
6 5 空白(無) 4(緑) 空白(無) 5(黄)
7
8 名前 日数 最少 最大 合計 平均
9 山田(赤)
10 鈴木(青) 24 0 12 84 3.5
11 佐藤(黄)
12 田中(緑)
私なりにコードを調整しようと試みたのですが…チンプンカンプンです(^_^;) ・上記のデータは，実際には，A1:A6とA8:F12をそれぞれ罫線で，別の表として表示させてあります。 表1，店舗別売り上げ集計表(A1:A6) 表2，個人別売り上げ集計表(A8:F12) そして，B6,D5,D6の空白セルには，実際には斜めの罫線も入れてます。 これが原因なのかなと思い，斜めの罫線をやめてみましたが，関係ないようです。 ・B5に入力した「―（ダッシュ）」がネックになっているのかなと思い，とりあえず0を入力しても B10の結果が25になるだけで，上手くいかないようです。
お時間がある時で結構ですので，よろしくお願い致します。
(マクロす，改め，がんバルキリー)
こちらで、同じレイアウトで動かしてバッチリなんだけどね？
考えられるとしたら、B2領域とA8領域の文字色が同じ黄色でも違うとか？ 念のため、説明のあったレイアウト（罫線つき）でも試してみるけど。
(ぶらっと)
縦横の入替だけだけどね・・・。 空白セルは全て対象外との前提です。
Sub TestB()
Dim i&, j&, r As Range, v, w, x, S
Dim D As Object, n&, m&
Set D = CreateObject("scripting.dictionary")
n = 8
S = Split("Connt,Min,Max,Sum,Ave", ",")
ReDim v(1 To 20, 1 To 6) 'Max 20色
For j = 0 To 4
v(1, j + 2) = S(j)
Next
m = 1
For Each r In Range("b2:f6") '検索範囲 任意設定
If r <> "" Then
x = r.Interior.Color
If Not D.exists(x) Then
m = m + 1
D(x) = m
v(m, 1) = x
v(m, 3) = 1000: v(m, 4) = 0
End If
n = D(x)
v(n, 2) = v(n, 2) + 1 'Count
If IsNumeric(r.Value) Then
If r.Value < v(n, 3) Then v(n, 3) = r.Value 'Min
If r.Value > v(n, 4) Then v(n, 4) = r.Value 'Max
v(n, 5) = v(n, 5) + r.Value 'Sum
v(n, 6) = Format(v(n, 5) / v(n, 2), ".00") 'Ave
End If
End If
Next
'展開処理
Cells(8, 1).Resize(m, 6).Value = v
For Each v In Cells(8, 1).Offset(1).Resize(m - 1)
v.Interior.Color = v.Value
Next
Set D = Nothing
End Sub
(暇人)
疑うわけじゃないけど（実は疑っているんだけどね）アップされた通りのデータシートに対して、 以下のTestSetを実行して名前と表内の文字色を一致させたうえで提示したSample を動かしてみてくれる？
Sub TestSet()
Range("B2,C4,D3,E6,C5,A11").Font.Color = vbYellow
Range("C2,E3,B4,A10").Font.Color = vbBlue
Range("D2,C3,E4,E5,C6,A12").Font.Color = vbGreen
Range("B3,E2,D4,A9").Font.Color = vbRed
End Sub
(ぶらっと)
わゎゎｌ！！！
文字色じゃなく背景色だったね！！ ごめん。
アップしたコードの .Font. を .Interior. にかえてもらえればいいんだけど、間違えたお詫びにフルセット。
Option Explicit
Enum ListItem
dummy
cnt
Min
Max
tot
ave
End Enum
Sub Sample()
Dim dicN As Object
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Set dicN = CreateObject("Scripting.Dictionary")
Set dicD = CreateObject("Scripting.Dictionary")
With Range("A8").CurrentRegion.Offset(1)
ReDim v(1 To .Rows.Count - 1, 1 To 5)
For Each c In .Columns(1).Resize(.Rows.Count - 1).Cells
dicN(c.Interior.Color) = dicN.Count + 1
dicD(c.Interior.Color) = False
Next
End With
With Range("A1").CurrentRegion.Offset(1)
For Each c In .Resize(.Rows.Count - 1)
If IsNumeric(c.Value) Then
myColor = c.Interior.Color
If dicN.exists(myColor) Then
i = dicN(myColor)
v(i, cnt) = v(i, cnt) + 1
v(i, tot) = v(i, tot) + c.Value
If c.Value > v(i, Max) Then v(i, Max) = c.Value
If dicD(myColor) Then
If c.Value < v(i, Min) Then v(i, Min) = c.Value
Else
v(i, Min) = c.Value
dicD(myColor) = True
End If
End If
End If
Next
End With
For i = LBound(v, 1) To UBound(v, 1)
If v(i, cnt) > 0 Then v(i, ave) = WorksheetFunction.RoundDown(v(i, tot) / v(i, cnt), 1)
Next
Range("B9").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
(ぶらっと)
まずは提示のデータ範囲固定であることと編集はまだですが、とりあえず試作品です。 こちらでのコピペデータではそれなりですが。。。
Sub ATest()
Dim Myo As Range, Wt(1 To 4, 1 To 5) As Variant, ix As Long, Myd
Set Myd = Todic([A9:A12])
For Each Myo In [B2:E6]
If Myo.Value <> "" And Myo.Value <> "―" Then
ix = Myd(Myo.Interior.Color)
Wt(ix, 1) = Wt(ix, 1) + IIf(Myo.Value = "－", 0, 1)
If IsEmpty(Wt(ix, 2)) Then
Wt(ix, 2) = Myo.Value
Else
Wt(ix, 2) = Application.Min(Wt(ix, 2), Myo.Value)
End If
Wt(ix, 3) = Application.Max(Wt(ix, 3), Myo.Value)
Wt(ix, 4) = Wt(ix, 4) + Val(Myo.Value)
Wt(ix, 5) = Application.RoundDown(Wt(ix, 4) / Wt(ix, 1), 1)
End If
Next
[B9].Resize(UBound(Wt), UBound(Wt, 2)).Value = Wt
End Sub
Function Todic(Wr As Range) As Object
Dim Myo As Range, Ctr As Long, Myd, W1
Set Myd = CreateObject("Scripting.dictionary")
For Each Myo In Wr
W1 = Myo.Interior.Color
If Myd.exists(W1) = False Then Ctr = Ctr + 1
Myd(W1) = Ctr
Next
Set Todic = Myd
End Function
（Cod）
Codさんの方式を借用して、数値取得を全て、シート関数で行うようにした案。
追記）4/6 10:18 アップしてながめなおしたら配列の列指定は、一ヶ所にまとまっているので Enumステートメントをやめて、配列の列を直接 1,2,3・・・で指定してもよかったかもね。
Option Explicit
Enum ListItem
dummy
cnt
Min
Max
tot
ave
End Enum
Sub Sample2()
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Dim w As Variant
Set dicD = CreateObject("Scripting.Dictionary")
With Range("A1").CurrentRegion.Offset(1, 1)
For Each c In .Resize(.Rows.Count - 1, .Columns.Count - 1)
If IsNumeric(c.Value) Then
myColor = c.Interior.Color
If Not dicD.exists(myColor) Then
dicD(myColor) = Array(c.Value)
Else
w = dicD(myColor)
ReDim Preserve w(LBound(w) To UBound(w) + 1)
w(UBound(w)) = c.Value
dicD(myColor) = w
End If
End If
Next
End With
With Range("A8").CurrentRegion
ReDim v(1 To .Rows.Count - 1, 1 To 5)
For Each c In .Offset(1).Resize(.Rows.Count - 1).Columns(1).Cells
myColor = c.Interior.Color
i = i + 1
If dicD.exists(myColor) Then
w = dicD(myColor)
v(i, cnt) = UBound(w) + 1
v(i, Min) = WorksheetFunction.Min(w)
v(i, Max) = WorksheetFunction.Max(w)
v(i, tot) = WorksheetFunction.Sum(w)
v(i, ave) = WorksheetFunction.RoundDown(WorksheetFunction.Average(w), 1)
End If
Next
End With
Range("B9").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
(ぶらっと)
アップ済みのSampe2の前半部分の配列セットを少～しだけ整理。 これにともない件数もシート関数を使用。
Sub Sample3()
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Dim w As Variant
Dim base() As Variant
Set dicD = CreateObject("Scripting.Dictionary")
With Range("A1").CurrentRegion.Offset(1, 1)
ReDim base(1 To (.Rows.Count - 1) * (.Columns.Count) + 1) '最大可能要素数
base(1) = 1
For Each c In .Resize(.Rows.Count - 1, .Columns.Count - 1)
If IsNumeric(c.Value) Then
myColor = c.Interior.Color
If Not dicD.exists(myColor) Then dicD(myColor) = base
w = dicD(myColor)
w(1) = w(1) + 1
w(w(1)) = c.Value
dicD(myColor) = w
End If
Next
End With
With Range("A8").CurrentRegion
ReDim v(1 To .Rows.Count - 1, 1 To 5)
For Each c In .Offset(1).Resize(.Rows.Count - 1).Columns(1).Cells
myColor = c.Interior.Color
i = i + 1
If dicD.exists(myColor) Then
w = dicD(myColor)
w(1) = Empty
v(i, cnt) = WorksheetFunction.Count(w)
v(i, Min) = WorksheetFunction.Min(w)
v(i, Max) = WorksheetFunction.Max(w)
v(i, tot) = WorksheetFunction.Sum(w)
v(i, ave) = WorksheetFunction.RoundDown(WorksheetFunction.Average(w), 1)
End If
Next
End With
Range("B9").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
(ぶらっと)
ぶらっとさん，Codさん，暇人さん，返事が遅れて申し訳ありません。 留守にしている間に，たくさんの回答ありがとうございます。
暇人さんのコードですと，[A9:A12]と[B8:F8]の入力項目が書き換えられてしまうようです。 ぶらっとさんとCodさんが示されたコードでやると，[B9:F12]の一括処理の部分だけが計算されて表示されたので， このお二方のコードを使わさせて頂きます。 ただ，やはり何がどうのようなコードの仕組みなのかが，全く理解できないため…頭がフリーズしてしまいました(^_^;)
いまトライしていることは，以下のように上下それぞれの表にタイトルを付けたいので，行を挿入(1行と9行)します。 そして，下表では名前の前列に固有の記号を入力するためのセルを追加します。 その結果，入力範囲を[B3:E7]と[A11:B14]，一括処理の表示セルを[C11:G14]に変更したいのです， ぶらっとさんの最終提案版とCodさんの最終提案版のどちらも色々やってみたのですが，それさえもできません(泣)
A B C D E F G
1 表①ﾀｲﾄﾙ
2 日数 越後屋 三河屋 大和屋 備前屋
3 1 3(黄) 7(青) 6(緑) 5(赤)
4 2 4(赤) 3(緑) 0(黄) 4(青)
5 3 4(青) 6(黄) 2(赤) 1(緑)
6 4 ―(青) 12(黄) 空白(無) 3(緑)
7 5 空白(無) 4(緑) 空白(無) 5(黄)
8
9 表②ﾀｲﾄﾙ
10 記号 名前 日数 最少 最大 合計 平均
11 X-007 山田(赤) 3 2 5 11 3.6
12 AD-33 鈴木(青) 3 4 7 15 5.0
13 578BW 佐藤(黄) 5 0 12 26 5.2
14 ODY-9 田中(緑) 5 1 6 17 3.4
そもそも，お二人のコードの違いも理解できていないのですが，今後実験の種類によっては，表①の入力範囲[B3:E7]が 35列×60行に増え，表②の入力範囲[A11:B14]も2列×20行に増えることがあります。 これに対応するには，どちらのコードが適していますでしょうか？ お願いばかりで申し訳ありませんが，ご教示頂ければ幸いですm(__)m
(マクロす，改め，強風によって見ず知らずの町まで飛ばされ，なんとか生還したバルキリー)
Q1.今は表1と表2が同一シートの前提にしてますが、特に表１の行数が増えるのであれば
表２は A11:B30 としても かぶるので 別シートと言う事ですか？
それとも 表1の終了行 ＋ ２行目から書き出しでしょうか？
注）恐らく別シートの方が少しでもスッキリすると思いますが。
（Cod）
Codさん同様、シートを分けた方が、今後の拡張時に柔軟に対応できるとおもうけど、ともあれ。 できるだけ、わかりやすくするため、Enumステートメントは使わず、配列の列番号を直接、数字で規定。 そのほか、できるだけ、領域の場所を、固定のセル番号で記述。
ところで、コードとは関係ないけど、前から気になっていたことがある。 表①のＡ列の日数って何かな？表②の日数とは、全く別物のようだし。
Sub Sample4()
Dim r1 As Range
Dim x As Long
Dim y As Long
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Dim w As Variant
Dim base() As Variant
Set dicD = CreateObject("Scripting.Dictionary")
'表①のデータ領域
x = Cells(2, Columns.Count).End(xlToLeft).Column - 1 'B列から最終列までの列数
y = 5 '3行目から7行目までの行数
Set r1 = Range("B3").Resize(y, x) 'B3を起点にした表①の領域
ReDim base(1 To r1.Count) '最大可能要素数
base(1) = 1
For Each c In r1 '表①の各セルを抽出
If IsNumeric(c.Value) Then '数値のみ対象
myColor = c.Interior.Color 'そのセルの色番号
If Not dicD.exists(myColor) Then dicD(myColor) = base 'Dictionaryにその色番号の登録がなければ初期値として配列をセット
w = dicD(myColor) 'その色番号に登録された配列
w(1) = w(1) + 1 '配列の最初の要素がセルの値を格納する要素番号
w(w(1)) = c.Value '配列内にセルの値を追加登録
dicD(myColor) = w '配列をDictionaryに書き戻す
End If
Next
'表②のデータ領域
x = 5 'C列からG列までの5列
y = Range("B" & Rows.Count).End(xlUp).Row - 10 '11行目から最終行までの行数
ReDim v(1 To y, 1 To x) '表②に書き込むための表②と同じ大きさの配列
For Each c In Range("B11").Resize(y) '名前領域からセルを取り出す
myColor = c.Interior.Color 'そのセルの色番号
i = i + 1 '配列内行番号
If dicD.exists(myColor) Then
w = dicD(myColor)
w(1) = Empty
v(i, 1) = WorksheetFunction.Count(w)
v(i, 2) = WorksheetFunction.Min(w)
v(i, 3) = WorksheetFunction.Max(w)
v(i, 4) = WorksheetFunction.Sum(w)
v(i, 5) = WorksheetFunction.RoundDown(WorksheetFunction.Average(w), 1)
End If
Next
'表②の値を配列で置きかえ。
Range("C11").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
(ぶらっと)
その都度、シート構成が、少しづつずれているようですが・・・。 表2タイトルの、B列:名前 の欄は、事前に Color処理されているものとします。 表1,表2 は、最終的に別シートにした方がよさそうな気がしますね・・・。
Sub TestC()
Dim i&, n&, r As Range, v, x
Dim D As Object
Set D = CreateObject("scripting.dictionary")
ReDim v(1 To 4, 1 To 5) '展開用配列準備 4人*5項目
For i = 1 To 4
v(i, 2) = 1000: v(i, 3) = 0 '仮のMin,MaxをSet
Next
For i = 11 To 14 '11～14行
n = n + 1
x = Cells(i, 2).Interior.Color 'B列のColorNo
D(x) = n 'key:ColorNo item:行番号
Next
For Each r In Range("b3:f7") '検索範囲 任意設定可
x = r.Interior.Color
If D.exists(x) Then
n = D(x)
If IsNumeric(r.Value) Then
v(n, 1) = v(n, 1) + 1 '日数
If r.Value < v(n, 2) Then v(n, 2) = r.Value 'Min
If r.Value > v(n, 3) Then v(n, 3) = r.Value 'Max
v(n, 4) = v(n, 4) + r.Value 'Sum
v(n, 5) = Format(v(n, 4) / v(n, 1), ".00") 'Ave
End If
End If
Next
'展開処理
Cells(11, "c").Resize(UBound(v), UBound(v, 2)).Value = v
Set D = Nothing
End Sub
"-" 対応に一部修正しました。4/12 13:50
(暇人)
Codさん，ぶらっとさん，暇人さん，回答ありがとうございます。
Codさんからの質問＆ご意見 >Q1.今は表1と表2が同一シートの前提にしてますが、特に表１の行数が増えるのであれば > 表２は A11:B30 としても かぶるので 別シートと言う事ですか？ > それとも 表1の終了行 ＋ ２行目から書き出しでしょうか？ > 注）恐らく別シートの方が少しでもスッキリすると思いますが。 表1の行数をあらかじめ最大の60行にしておいて，表1の終了行＋2行目から書き出しにして置けば， 今後，販売員(実験物質)が30行で済む場合は，いらない行を「非表示」で隠して，印刷しようと思って ました(^_^;)
ぶらっとさんからの質問＆ご意見 >Codさん同様、シートを分けた方が、今後の拡張時に柔軟に対応できるとおもうけど、ともあれ。 >できるだけ、わかりやすくするため、Enumステートメントは使わず、配列の列番号を直接、数字で規定。 >そのほか、できるだけ、領域の場所を、固定のセル番号で記述。 おぉっ，コードの意味が解りました！いや，まぁなんとなくですけど(^_^;)
>ところで、コードとは関係ないけど、前から気になっていたことがある。 >表①のＡ列の日数って何かな？表②の日数とは、全く別物のようだし。 あっ，いやあくまでも例えなんで，実際は日数でもなんでもなく・・・ 例を作る際に，簡潔に二文字で収まる言葉にしようと選んだだけです(汗)
暇人さんからの質問＆ご意見 >その都度、シート構成が、少しづつずれているようですが・・・。 いや～，誠に申し訳ありません。一番最初は，できるだけ簡単な例を作って，皆さんの手を煩わせないようにと 思ってたんですが・・・結局，お手を煩わせてしまいすみませんm(__)m 早速実行させて頂きました。が…B6の「―（ダッシュ）」がカウントされてしまって，C12の日数(あ，実際は日数 じゃないんですけども)が4になってしまいます。平均値は15/3=5.0となっているのですが，この日数も3と表示 された方が有り難いのです。
以上，試行錯誤の結果，ぶらっとさんの方法でなんとか求める形になってきました。 皆さん色々と考えて下さって有難うございました。
PS.でも・・・もしかして，表1と表2を別シートで考えた方が，今後のことを考えると楽なんでしょうか？ って，あ，いや，独り言です(^_^)
(マクロす，改め，・・・と思ったが，なんにも思いつかないので止めときます。では♪)
>でも・・・もしかして，表1と表2を別シートで考えた方が，今後のことを考えると楽なんでしょうか？
そりゃぁそうだよ。
・リストの行数が多くなって、下のリストの場所まで行ってしまうと、下のリスト領域の設定も直さなきゃいけない。 ・なによりも、マクロで領域を特定する場合、その領域が、A1 から始まっていると、幸せなことが多い。 なので、表２も別シートの A1 から始まっていると、いいことがたくさんある。
(ぶらっと)
ぶらっとさんのコードを利用させて頂き，表①の領域を最大35列×60行で設定し，いらない行は「非表示」 で隠して，印刷することで，良しとしていたのですが・・・
(1) 表①の領域の中から特定の列だけを集計させるにはどのように考えたらよいのでしょうか？
前回の例を使用して説明すると，以下の表③や表④のように，表①B列の三河屋だけを集計，あるいは， 表①B列の三河屋と表①E列の備前屋の2つを集計させるなどのマクロを作成したいのです。
A B C D E F G
1 表①全店舗の集計
2 日数 越後屋 三河屋 大和屋 備前屋
3 1 3(黄) 7(青) 6(緑) 5(赤)
4 2 4(赤) 3(緑) 0(黄) 4(青)
5 3 4(青) 6(黄) 2(赤) 1(緑)
6 4 ―(青) 12(黄) 空白(無) 3(緑)
7 5 空白(無) 4(緑) 空白(無) 5(黄)
8
9 表②個人別の集計
10 記号 名前 日数 最少 最大 合計 平均
11 X-007 山田(赤) 3 2 5 11 3.6
12 AD-33 鈴木(青) 3 4 7 15 5.0
13 578BW 佐藤(黄) 5 0 12 26 5.2
14 ODY-9 田中(緑) 5 1 6 17 3.4
15
16 表③個人別の集計(三河屋)
17 記号 名前 日数 最少 最大 合計 平均
18 X-007 山田(赤) 0
19 AD-33 鈴木(青) 1 7 7 7 7.0
20 578BW 佐藤(黄) 2 6 12 18 9.0
21 ODY-9 田中(緑) 2 3 4 7 3.5
22
23 表④個人別の集計(三河屋と備前屋)
24 記号 名前 日数 最少 最大 合計 平均
25 X-007 山田(赤) 1 5 5 5 5.0
26 AD-33 鈴木(青) 2 4 7 11 5.5
27 578BW 佐藤(黄) 3 5 12 23 7.6
28 ODY-9 田中(緑) 4 1 4 11 2.7
ん～，こうなってくると，やはり各表を別シートで考えた方が，幸せでいいことがたくさんありそうですね(^_^;)
(2) 集計前の元の数値を別シートに抜き出し，個人別に整理して羅列させることは可能でしょうか？
例えば，山田(赤)の集計前の元の数値とは，表①のB:4，D:5，E:3の数値であり，それぞれ 4，2，5のことです。これを個人別に一列に書き出した表を作成させたいのです。 そうすれば，これを基に棒グラフや散布図などのグラフを作成しやすいと考えたものですから・・・
お願いばかりで申し訳ありませんが，ご教示頂ければ幸いですm(__)m (マクロす，改め，マクロはムズカシイっす)
お尋ねの、a:「特定列だけの集計」 b:「元の数値を別シートへ抽出」 いずれも可能です。 但し、現在のミニサンプルで、コードを提示しても、最終形がはっきりしない事には、何度も変更を繰り返すだけの事です。 まずは、最終の形をしっかりと見据えたうえで、全体の構想を考える事が大切です。
表1 も、最終的に、35列 * 60行程度になるとの事ですが、これとて、単に見やすくするための集計表にすぎません。 月日、氏名、場所、数量の、4つの Item が、あくまでも基本データです。 現在、氏名の代わりに、Color表示を利用していますが、今後 30色以上の、色を使い分けるつもりですか ? この、表1 の作成そのものも、結構大変な作業になりそうな気がしますが・・・・。 ここでも、基本データから、表1 を作成するためのコードも必要になるはずですね。 現在この基本データはどのような形で管理されてるのでしょうか ?
また、今回お尋ねの、「特定列を指定した集計」にしても、今後 35列にもなった場合、 まさか、全ての組み合わせの集計表を作っておくわけにもいきませんよね・・・・・。 実際にどんな組み合わせが必要になるのか、またそれを、どのように指定するかが一つのポイントになります。
また、「元の数値を別シートへ抽出」も、具体的にどこにどう表示したいのかが見えませんね。
おそらくは、今後全体を管理するためには、UserForm の導入などが必要になってくるのかな ? 具体的なコードの作成をお手伝いすることは、やぶさかではありませんが、私たちには全体像が見えません。 このような場でのやり取りだけではやはりおのずから限度があります。
なんか、説教ぽくなってしまったけどごめんなさいね。 (暇人)
おそらく・・・・暇人さんも示唆されているように、業務運用のなかでデータを、どのように管理していくか 実際の業務の流れと、データレイアウト含めたデータの構成がミスマッチ（失礼）しているような気がするね。
想像だけど、担当別に色がアサインされていて、山田さんは赤。 で、表①のような、全員が見る表があって、たとえば山田さんが三河屋と２の取引ができたらこの①の表の 三河屋の列の空白セルに、２ を記入して、そこを赤く塗る。 このマトリックスをみんなで見ながら、だれが、どこにどれぐらいの実績を上げているかを把握する・・・
と、まぁ、こんな運用なのかな？
私が、この業務処理方式を策定するとすれば、おそらく、個人別シートでも共通シートでもいいんだけど A列に名前、B列に取引先、C列に実績数値 等々、必要な情報をリストとして入力しておく。 で、必要な時に、このデータリストから 表①を作成したり、表②を作成したり、表③を作成したり、 とにかく、必要な時に必要な形のアウトプットを作成するという構えにすると思う。
現在の方式は、この【アウトプット様式】（つまり、データ入力やデータ管理には適していない様式）を もとにして情報分析・加工を行おうとしている、そこに壁があるんじゃないかなと思うね。
(ぶらっと)
自分の意見としては↑でコメントしたとおりだけど、そちらの要望にあわせるとすれば。 以下の Sample5 が 取引先指定（オプション）による①->②。 ただし、①も②も別シート。ともに１行目に何か表名がはいっていて、２行目がタイトル行。 データは３行目から。
Call SubProc("Sheet1", "Sheet2") このように、①のシート名と②のシート名を記述。
もし、取引先を絞りたい場合は、取引先名を一次元配列に格納したものを
Call SubProc("Sheet1", "Sheet2", v) こんなふうにして実行。
以下のサンプルでは越後屋と三河屋を指定。
①から、明細一覧を作成するのが Sample6。 ただし、①の表で、赤が誰かはわからないので 一覧上では、名前空白、色のみ としている。 ①が"Sheet1"、一覧が"Sheet3" としている。
Sub Sample5()
Dim v As Variant
v = Array("越後屋", "三河屋") 'Array関数に限らず、要は一次元配列で、必要な取引先を指定
Call SubProc("Sheet1", "Sheet2", v)
' Call SubProc("Sheet1", "Sheet2") '第３引数を省略すれば全取引先
End Sub
Sub SubProc(snF As String, snT As String, Optional inClient As Variant)
Dim shF As Worksheet
Dim shT As Worksheet
Dim myClient As String
Dim a As Variant
Dim flag As Boolean
Dim r1 As Range
Dim x As Long
Dim y As Long
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Dim w As Variant
Dim base() As Variant
Set shF = Sheets(snF)
Set shT = Sheets(snT)
Set dicD = CreateObject("Scripting.Dictionary")
'表①のデータ領域
With shF
x = .Cells(2, .Columns.Count).End(xlToLeft).Column - 1 'B列から最終列までの列数
y = .Range("A2").End(xlDown).Row - 2 '3行目から最終行までの行数
Set r1 = .Range("B3").Resize(y, x) 'B3を起点にした表①の領域
End With
ReDim base(1 To r1.Count + 1) '最大可能要素数
base(1) = 1
For Each c In r1 '表①の各セルを抽出
flag = True
If IsNumeric(c.Value) Then '数値のみ対象
If Not IsMissing(inClient) Then '取引先指定なし
myClient = shF.Cells(2, c.Column).Value
a = Application.Match(myClient, inClient, 0)
If Not IsNumeric(a) Then flag = False
End If
If flag Then
myColor = c.Interior.Color 'そのセルの色番号
If Not dicD.exists(myColor) Then dicD(myColor) = base 'Dictionaryにその色番号の登録がなければ初期値として配列をセット
w = dicD(myColor) 'その色番号に登録された配列
w(1) = w(1) + 1 '配列の最初の要素がセルの値を格納する要素番号
w(w(1)) = c.Value '配列内にセルの値を追加登録
dicD(myColor) = w '配列をDictionaryに書き戻す
End If
End If
Next
'表②のデータ領域
With shT
x = 5 'C列からG列までの5列
y = .Range("B" & .Rows.Count).End(xlUp).Row - 2 '3行目から最終行までの行数
End With
ReDim v(1 To y, 1 To x) '表②に書き込むための表②と同じ大きさの配列
For Each c In shT.Range("B3").Resize(y) '名前領域からセルを取り出す
myColor = c.Interior.Color 'そのセルの色番号
i = i + 1 '配列内行番号
If dicD.exists(myColor) Then
w = dicD(myColor)
w(1) = Empty
v(i, 1) = WorksheetFunction.Count(w)
v(i, 2) = WorksheetFunction.Min(w)
v(i, 3) = WorksheetFunction.Max(w)
v(i, 4) = WorksheetFunction.Sum(w)
v(i, 5) = WorksheetFunction.RoundDown(WorksheetFunction.Average(w), 1)
End If
Next
'表②の値を配列で置きかえ。
shT.Range("C3").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
Sub Sample6()
Dim shF As Worksheet
Dim shT As Worksheet
Dim myClient As String
Dim a As Variant
Dim flag As Boolean
Dim r1 As Range
Dim x As Long
Dim y As Long
Dim dicD As Object
Dim v() As Variant
Dim c As Range
Dim i As Long
Dim myColor As Long
Dim w As Variant
Application.ScreenUpdating = False
Set shF = Sheets("Sheet1") '元シート
Set shT = Sheets("Sheet3") '転記先シート
Set dicD = CreateObject("Scripting.Dictionary")
'表①のデータ領域
With shF
x = .Cells(2, .Columns.Count).End(xlToLeft).Column - 1 'B列から最終列までの列数
y = .Range("A2").End(xlDown).Row - 2 '3行目から最終行までの行数
Set r1 = .Range("B3").Resize(y, x) 'B3を起点にした表①の領域
End With
ReDim v(1 To r1.Count + 1, 1 To 3) '最大可能要素数
For Each c In r1 '表①の各セルを抽出
flag = True
If IsNumeric(c.Value) And Not c.Interior.ColorIndex = xlNone Then '色つき数値のみ対象
myClient = shF.Cells(2, c.Column).Value
myColor = c.Interior.Color 'そのセルの色番号
dicD(myColor & myClient) = dicD.Count + 1 '当該色番号の配列内行番号
i = dicD(myColor & myClient)
v(i, 1) = myColor
v(i, 2) = myClient
v(i, 3) = c.Value
End If
Next
With shT '転記先シート
.Cells.ClearContents
.Columns("A").Interior.ColorIndex = xlNone
.Range("A1:C1").Value = Array("担当", "取引先", "実績")
.Range("A2").Resize(UBound(v, 1), 3).Value = v
.Range("A1").CurrentRegion.Sort Key1:=Columns("A"), Order1:=xlAscending, Header:=xlYes
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
c.Interior.Color = c.Value
c.ClearContents
Next
.Select
End With
Application.ScreenUpdating = True
End Sub
(ぶらっと)
基本データから、表1を作成するサンプルです。
シート名を、Data として、下記に準じてサンプルデータを作成してください。
なを、F列の、氏名リストには、それぞれの氏名に応じて、任意の背景色を設定しておくこと。
また、転記先のシート名 Sheet1 (適宜変更)の、A列は、書式設定で、「日付」で事前設定。
F列:氏名,H列:場所 のリストを追加すれば、それに応じた集計表が作成されます。
Sheets("Data")
A B C D E F G H
1 月日 氏名 場所 数量 氏名 場所
2 4/1 佐藤 越後屋 3 山田 越後屋
3 4/1 鈴木 三河屋 7 鈴木 三河屋
4 4/1 田中 大和屋 6 佐藤 大和屋
5 4/1 山田 備前屋 5 田中 備前屋
6 4/2 山田 越後屋 4
7 4/2 田中 三河屋 3
8 4/2 佐藤 大和屋 0
9 4/2 鈴木 備前屋 4
10 4/3 鈴木 越後屋 4
11 4/3 佐藤 三河屋 6
12 4/3 山田 大和屋 2
13 4/3 田中 備前屋 1
14 4/4 鈴木 越後屋 -
15 4/4 佐藤 三河屋 12
16 4/4 田中 備前屋 3
17 4/5 田中 三河屋 4
18 4/5 佐藤 備前屋 5
Sub Make表1()
Dim i&, j&, m&, n&, S, D As Object, v, w
Dim r&, c&, Sh As Worksheet
Set D = CreateObject("scripting.dictionary")
Set Sh = Sheets("Sheet1") '****展開先Sheet名 適宜変更****
With Sheets("Data") '基本データ
v = .Cells(1, 1).CurrentRegion.Value2
i = 2: n = 2
Do 'Color Set
S = .Cells(i, "f").Value
D(S) = .Cells(n, "f").Interior.Color
i = i + 1: n = n + 1
Loop While .Cells(i, "f").Value <> ""
i = 2: n = 2
Do '場所 Set
S = .Cells(i, "h").Value
D(S) = n
Sh.Cells(2, n).Value = S
i = i + 1: n = n + 1
Loop While .Cells(i, "h").Value <> ""
i = 2: n = 3
Do '月日 Set
S = .Cells(i, "a").Value2
If Not D.exists(S) Then
D(S) = n
Sh.Cells(n, 1).Value = S
n = n + 1
End If
i = i + 1
Loop While .Cells(i, "a").Value <> ""
End With
'展開処理
Sh.Cells(1, 1).Value = "タイトルA"
Sh.Cells(2, 1).Value = "日付"
For i = 2 To UBound(v)
r = D(v(i, 1)): c = D(v(i, 3))
With Sh.Cells(r, c)
.Value = v(i, 4)
.Interior.Color = D(v(i, 2))
End With
Next
Set D = Nothing
End Sub
(暇人)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.