該当のセルの他の項目を取り出すマクロ

質問

いつもお世話になっております。

初心者なのですが、、、マクロについて教えていただけますでしょうか？
エクセルファイルで9000行×NN行の表があります。（列は増えませんが、行は増えます。）

--------------------------------------------------------------------------------------------------------------------
A列　　　　B列　　　　C列　　　　　　D列　　　　　　E列　　　　　　F列
--------------------------------------------------------------------------------------------------------------------
名前　　企画番号　　2015/12/1　　　2015/12/2　　　2015/12/3　　　2015/12/4
Aさん　　P410　　　　　　7　　　　　　　0　　　　　　0　　　　　　6
Bさん　　P500　　　　　　0　　　　　　　9　　　　　　5　　　　　　3
Cさん　　P043　　　　　　0　　　　　　　0　　　　　　0　　　　　　0
Aさん　　P403　　　　　　4　　　　　　　0　　　　　　0　　　　　　0
Cさん　　P789　　　　　　0　　　　　　　0　　　　　　0　　　　　　0
--------------------------------------------------------------------------------------------------------------------

条件書式で、
=SUMIF($A:$A,$A2,C:C)>10
「同じ人が同じ日付で10以上になったら」赤く塗りつぶすようにしています。
（上の表の場合は、Aさんの2015/12/1の「7」と「4」に赤い塗りつぶし。）

ここから、以下のマクロを追加したいと思っています。

赤く塗りつぶしたセルの「名前」「日付」「企画番号」を新しいエクセルブックに取り出したい。
（上の表の場合は、「Aさん」「2015/12/1」「P410」「P403」の4セルを取り出したいです。）
取り出す企画番号が2つの場合もあれば、最大6つくらいまでなりそうです。

どうかよろしくお願いいたします。

回答No.1

Prome_Lin

01: Option Explicit
02: Sub Test()
03:　　 Const c As Integer = 6 '「NN」ならここは「378」
04:　　 Dim r, i, j, k, l, p, t(9999) As Integer
05:　　 Dim n(9999), m As String
06:　　 r = Range("A1").End(xlDown).Row
07:　　 l = -1
08:　　 p = 0
09:　　 For i = 2 To r
10:　　　　 m = Cells(i, 1).Value
11:　　　　 For j = 0 To l
12:　　　　　　 If n(j) = m Then
13:　　　　　　　　 p = 1
14:　　　　　　 End If
15:　　　　 Next j
16:　　　　 If p = 0 Then
17:　　　　　　 l = l + 1
18:　　　　　　 n(l) = m
19:　　　　 End If
20:　　 Next i
21:　　 For i = 3 To c
22:　　　　 For j = 0 To l
23:　　　　　　 t(j) = 0
24:　　　　 Next j
25:　　　　 For j = 0 To l
26:　　　　　　 For k = 2 To r
27:　　　　　　　　 If n(j) = Cells(k, 1).Value Then
28:　　　　　　　　　　 t(j) = t(j) + Cells(k, i).Value
29:　　　　　　　　 End If
30:　　　　　　 Next k
31:　　　　 Next j
32:　　　　 For j = 0 To l
33:　　　　　　 If t(j) > 10 Then
34:　　　　　　　　 For k = 2 To r
35:　　　　　　　　　　 If Cells(k, 1).Value = n(j) Then
36:　　　　　　　　　　　　 Cells(1, i).Interior.ColorIndex = 3
37:　　　　　　　　　　　　 Cells(k, 1).Interior.ColorIndex = 3
38:　　　　　　　　　　　　 Cells(k, 2).Interior.ColorIndex = 3
39:　　　　　　　　　　　　 Cells(k, i).Interior.ColorIndex = 3
40:　　　　　　　　　　 End If
41:　　　　　　　　 Next k
42:　　　　　　 End If
43:　　　　 Next j
44:　　 Next i
45: End Sub

本来は「A列からNN列」までなのですから、「03」行目は「378」になりますが、今は、サンプルで提示されている「A列からF列」までの「６」としています。
従って、ここは実際には、「378」になります。

「06」行目：
「A」列の最終行を取得しています（サンプル例の場合は、「６」になります）。

「07」行目から「20」行目まで：
実際のデータがあるのは、２行目からなので、２行目から最終行（「ｒ」）までに出てくるお名前を調べています。すなわち、「Ａさん」「Ｂさん」というように、「ｎ」配列変数に入れていくのですが、このとき、すでに「Ａさん」があれば、読み飛ばします。だからと言って、「Ａさん」が何回出てくるかは、調べていません。
これで、名簿が「ｎ」配列変数に入りました。

あとは、「Ａさん」について、「Ｂさん」について、それぞれの、「Ｃ」列なら「Ｃ」列の合計を出しています。

合計が「１０」を超えると、セルを「赤」で塗りつぶします。

それが済むと、「Ｄ」列で調べて、次に「Ｅ」列で調べて、と繰り返して行きます。

「36」行目から「39」行目で、赤く塗りつぶしているセルの場所（例えば「Cells(1, i)」）の「値」（.Value）を任意の場所に書き出せばいいのですが、ここで、どこにどう書き出せば良いのか、具体的に分からず、プログラムが止まってしまいました。

とにかくあとは、「Cells(1, i).Value」「Cells(k, 1).Value」「Cells(k, 2).Value」「Cells(k, i).Value」を、書き出したい所に、設定するだけです（例えば「Cells(1, 379).Value = Cells(1, i).Value」などです）。

もし、具体的に書き出したい場所のご指示があれば、プログラムを追加訂正します。

お礼

ありがとうございました。