エクセルでの一括データ処理(日付補完など)

エクセルによるデータ整理に手を焼いています。
データファイルを下記の様に変換して整理したいと考えています。

＜元データ＞
[A]　　　　　　　[B]　　　　　　　[C]　　　　　　　[D]…
[1]日付1　　　　　値1　　　　　　　日付2　　　　　　値2
[2]2007/12/7　　　1　　　　　　　　2007/12/5　　　20
[3]2007/12/9　　　4　　　　　　　　2007/12/6　　　30
[4]2007/12/11　　 3　　　　　　　　2007/12/7　　　15
[5]　　　　　　　　　　　　　　　　　 　2007/12/10　　10
[6]　　　　　　　　　　　　　　　　　 　2007/12/11　　10
(A5:B6は空白です)


＜変換後データ＞　
　　[A]　　　　　[B]　　　　　　[C]　　　　
[1]日付　　　　　値1　　　　　値2
[2]2007/12/5　　NA　　　　　20
[3]2007/12/6　　NA　　　　　30
[4]2007/12/7　　　1　　　　　15
[5]2007/12/8　　NA　　　　　NA
[6]2007/12/9　　　4　　　　　NA
[7]2007/12/10　　NA　　　　10
[8]2007/12/11　　3　　　　　10
("NA"部分は"0"あるいは空白で構いません)

同種の質問としてttp://oshiete.goo.ne.jp/qa/3911631.htmlを見つけましたが、
データファイルが大きいので、どうにかして一括で処理する方法を探しています。

やりたいことは、
(1)飛び飛びになっているデータの日付を補完し、
(2)日付を示す系列は1つだけに留めた上で日付に対応した値を並べる
です。

マクロによる処理でも関数による処理でも何でも構いませんので、
どなたか解決策をご教示していただけると助かります。

なお、実際に処理したいデータファイルは1000列ほどで、500種類くらいの値とそれらに対応した日付が並んでいます。
使用しているエクセルは2007です。

No.14 回答者： ki-aaa 回答日時： 2011/08/14 12:46

せっかく書いたので、投稿します。

Sub test()
Dim i As Long, j As Long, k As Long, n As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim 日付値表() As Long
Dim 最終列 As Long
Dim 最終行 As Long
Dim 最初の日 As Long
Dim 最後の日 As Long

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
最初の日 = DateSerial(3000, 12, 31)

ws2.Cells(1, 1) = "日付"
最終列 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To 最終列 Step 2
ws2.Cells(1, (j + 3) / 2) = ws1.Cells(1, j + 1)
最終行 = ws1.Cells(Rows.Count, j).End(xlUp).Row
If 最初の日 > WorksheetFunction.Min(ws1.Range(ws1.Cells(2, j), ws1.Cells(最終行, j))) Then
最初の日 = WorksheetFunction.Min(ws1.Range(ws1.Cells(2, j), ws1.Cells(最終行, j)))
End If
If 最後の日 < WorksheetFunction.Max(ws1.Range(ws1.Cells(2, j), ws1.Cells(最終行, j))) Then
最後の日 = WorksheetFunction.Max(ws1.Range(ws1.Cells(2, j), ws1.Cells(最終行, j)))
End If
Next j

ReDim 日付値表(最初の日 To 最後の日, 1 To 最終列 / 2 + 1)
' 日付を直接、テーブルの引数にしている
For i = 最初の日 To 最後の日
日付値表(i, 1) = i
Next i

For j = 1 To 最終列 Step 2
For i = 2 To ws1.Cells(Rows.Count, j).End(xlUp).Row
日付値表(ws1.Cells(i, j).Value, (j + 3) / 2) = ws1.Cells(i, j + 1)
Next i
Next j

ws2.Cells(2, 1).Resize(最後の日 - 最初の日 + 1, 最終列 / 2 + 1).Value = 日付値表

Erase 日付値表
End Sub

No.13 回答者： mitarashi 回答日時： 2011/08/14 12:44

高速化にチャレンジしてみました。

xl2000なので、1000列という訳にはいきませんが、250列、10000行のデータで数秒で済みました（PentiumM 1.33GHz)。元気があったら、xl2010でデータを増やしてトライしてみます。
前提：日付の列は日付型で入っている。対応するデータが無い箇所は空白とする。
2007/1/1～2011/12/31の期間に対応。Sheet1のデータをSheet2にまとめる。
それぞれの日付と値の種類数に応じた、日付のシリアル値でアクセス出来る配列を作成して、そこにデータを入れ込み、一括して別シートに貼り付けるという案です。期間の変更は、Constのところを修正してください。

Sub test()
Dim targetRange As Range
Dim myArray() As Variant
Dim targetColumn As Long, i As Long, j As Long
Dim buf As Variant
Dim lastColumn As Long

Const startDate As Date = #1/1/2007#
Const endDate As Date = #12/31/2011#

lastColumn = Sheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Column
ReDim myArray(CLng(startDate) To CLng(endDate), 1 To Int(lastColumn / 2) + 1)
For i = LBound(myArray, 1) To UBound(myArray, 1)
myArray(i, 1) = CDate(i)
Next i
For targetColumn = 1 To lastColumn Step 2
With Sheets("Sheet1")
Set targetRange = Range(.Cells(2, targetColumn), .Cells(Rows.Count, targetColumn + 1).End(xlUp))
End With
buf = targetRange
For i = 1 To UBound(buf, 1)
myArray(CLng(buf(i, 1)), Int(targetColumn / 2) + 2) = buf(i, 2)
Next i
Next targetColumn
With Sheets("Sheet2")
.Cells.Clear
Range(.Cells(1, 1), .Cells(UBound(myArray) - LBound(myArray) + 1, Int(lastColumn / 2) + 1)) = myArray
End With
End Sub

No.12 回答者： MackyNo1 回答日時： 2011/08/14 11:26

No11の回答の補足です。

質問で例示されているレイアウトのように、元のシートでデータがない日付も、まとめシートには追加したいなら（そのデータを空白表示したいなら）、先頭行(たとえばJ1セル）に「日付」と入力し、J2セルにデータにしたい開始日を入力し、下方向に終了日までオートフィルコピーした行全体を統合範囲に「追加」してください。

ただし、この条件の場合なら（データのない日付を飛ばして表示する必要がないなら）、あまり難しく考えずに、単純にVLOOKUP関数で対応する日付のデータを引っ張ってくるだけで良いと思うのですが・・・

No.11 回答者： MackyNo1 回答日時： 2011/08/14 11:00

ご希望の操作は「統合」の機能を利用するのが簡単です。

添付画像のように、項目名を「日付」と「値1」「値２」にして、F1セルにカーソルを置いて「データ」「統合」で統合元範囲の右のアイコンをクリックしてA列とB列全体を選択して「追加」で同様にC列とD列全体を選択し、上端行と左端列にチェックを入れて「OK」します。
日付の表示列がシリアル値で表示されますので、表示形式を日付に変更してください。

No.10 回答者： MASUKUBO 回答日時： 2011/08/14 08:54

回答No2です。

関数のみで解決することもわりと簡単ですね。
シート1に元の表があるとしてシート2のAおよびB列を作業列としてA1セルには日付1とでも入力し、シート1でのそれぞれの列でのもっとも古い日付を表示させることとし、A2セルには次の式を入力して下方にオートフィルドラッグします。

=IF(MIN(INDEX(Sheet1!$A:$ALM,2,ROW(A1)*2-1):INDEX(Sheet1!$A:$ALM,200,ROW(A1)*2-1))=0,"",MIN(INDEX(Sheet1!$A:$ALM,2,ROW(A1)*2-1):INDEX(Sheet1!$A:$ALM,200,ROW(A1)*2-1)))

B1セルには日付2とでも入力しそれぞれの列での最新の日付を表示させることとし、B2セルには次の式を入力して下方にオートフィルドッグします。

=IF(MAX(INDEX(Sheet1!$A:$ALM,2,ROW(A1)*2-1):INDEX(Sheet1!$A:$ALM,200,ROW(A1)*2-1))=0,"",MAX(INDEX(Sheet1!$A:$ALM,2,ROW(A1)*2-1):INDEX(Sheet1!$A:$ALM,200,ROW(A1)*2-1)))

C列から右側にはお求めの表を表示させるとしてC1セルには日付と入力したのちにC2セルには次の式を入力し下方にオートフィルドラッグします。

=IF(MIN(A:A)+ROW(A1)-1>MAX(B:B),"",MIN(A:A)+ROW(A1)-1)

C列の表示形式を日付にすることでC列にはシート1でのもっとも古い日付から最新の日付までが連続した日付として表示されます。

D1セルには値1と文字を入力し右横方向にオートフィルドラッグします。
D2セルには次の式を入力したのちに右横方向にオートフィルドラッグしたのちに下方向にもオートフィルドラッグします。

=IF($C2="","",IF(COUNTIF(INDEX(Sheet1!$A$1:$ALM$200,1,COLUMN(A1)*2-1):INDEX(Sheet1!$A$1:$ALM$200,200,COLUMN(A1)*2-1),$C2)=0,"",INDEX(Sheet1!$A$1:$ALM$200,MATCH($C2,INDEX(Sheet1!$A$1:$ALM$200,1,COLUMN(A1)*2-1):INDEX(Sheet1!$A$1:$ALM$200,200,COLUMN(A1)*2-1),0),COLUMN(A1)*2)))

作業列のAおよびB列が目障りであればそれらの列を選択して右クリックし「非表示」を選択すればよいでしょう。

No.9 回答者： kagakusuki 回答日時： 2011/08/14 07:49

　回答番号ANo.3です。

>実際は元データは以下の様な200行×1000列のファイルです。
>日付や値の行数はバラバラで200行まであるものもあれば、5行程度しかないものもあります。
>また、日付は飛び飛びの値になっています。

>　　 　[A]　　[B]　　[C]　　[D]　…　[ALK]　　[ALM]
>　[1]日付1　値1　　日付2　値2　　　日付500　値500


　そうでしたか、それは失礼しました。
　その場合は、適当な空きシートに作業列を設けるという方法が使えます。

　今仮に、＜元データ＞が入力されているシートがSheet1、＜変換後データ＞を表示させるシートがSheet2であるものとし、Sheet3を作業用のシートとして使用するものとします。

　まず、Sheet3のA1セルに、次の数式を入力して下さい。

=IF(LEFT(INDEX(Sheet1!$1:$1,COLUMN()),2)="日付",MIN(OFFSET(Sheet1!$A:$A,,COLUMN()-COLUMN(Sheet1!$A$1))),"")

　次に、Sheet3のA2セルに、次の数式を入力して下さい。

=IF(LEFT(INDEX(Sheet1!$1:$1,COLUMN()),2)="日付",MAX(OFFSET(Sheet1!$A:$A,,COLUMN()-COLUMN(Sheet1!$A$1))),"")

　次に、Sheet3のA1～A2の範囲をコピーして、同じ行のA列よりも右側にあるセルの範囲（＜元データ＞がALM列まで存在する場合はSheet3のB1～ALM2の範囲）に貼り付けて下さい。
　次に、Sheet3のA3セルに、次の数式を入力して下さい。

=MAX($2:$2)

　次に、Sheet2のA1セルに「日付」、B1セルに「値1」、C1セルに「値２」・・・・・、と言う具合に、各項目名を入力して下さい。
　次に、Sheet2のA2セルとA3セルの書式設定を[日付]として下さい。
　次に、Sheet2のA2セルに、次の数式を入力して下さい。

=IF(COUNT(Sheet3!$1:$1)=0,"",MIN(Sheet3!$1:$1))

　次に、Sheet2のA3セルに、次の数式を入力して下さい。

=IF(A$2+ROW()-ROW(A$2)>Sheet3!$A$3,"",A$2+ROW()-ROW(A$2))

　次に、Sheet2のB2セルに、次の数式を入力して下さい。

=IF($A2="","",IF(COUNTIF(OFFSET(Sheet1!$A:$A,,(COLUMNS($A:B)-2)*2),$A2)=0,"NA",VLOOKUP($A2,OFFSET(Sheet1!$A:$B,,(COLUMNS($A:B)-2)*2),2,FALSE)))

　次に、Sheet2のB2セルをコピーして、Sheet2のB3セルに貼り付けて下さい。
　次に、Sheet2のB2～B3の範囲をコピーして、同じ行のB列よりも右側にあるセルの範囲（＜元データ＞がALM列まで存在する場合はSheet3のC2～ALM3の範囲）に貼り付けて下さい。
　次に、Sheet2の3行目全体をコピーして、Sheet2の4行目以下に貼り付けて下さい。

　以上です。

No.8 回答者： sakuuuuu 回答日時： 2011/08/14 03:24

一回こっきりの処理であれば手動でやったほうが早いです。

（定期的な作業であればマクロ化）

ざっくり書くと

⇒　Ｃ行をＡ行の最下行の下に移動、Ｄ行はA行の最下行のC行に移動(ヘッダの項目名はいらない)

⇒　A行(日付)で並べ替え

⇒　A行(日付)をグループの基準とし、B行、C行は合計値を集計

⇒　集計行のみ別シートにコピペして「集計値」という文言を置換で消す
　　(完成形は別シートに作成します)

CTRL+方向キーで入力行の最後にセルを移動できるので
やり方が理解できれば数分の作業だと思います。

マクロ化する場合も、基本的には上記とほぼ同じ手順でしょうね。
A行に日付をそろえ、B行、C行に数値を設定し、
A行(日付)でソートしてからループ処理で上から集計していくという手順でしょうか。

もし可能であれば入力元のデータをエクセルに入力するときに
同じ属性のデータは1列にまとめるとよいと思います。(今回のデータでいうと「日付」)
あとからの編集が楽です。

No.7 回答者： tom04 回答日時： 2011/08/14 01:08

No.6です！

たびたびごめんなさい。

前回のコードでは同一日がある場合をまとめていませんでした。

↓のコードに訂正してみてください。

Sub test() 'この行から
Dim i, j, k, L As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1") '←「sheet1」の部分は実際のSheet名に！
Set ws2 = Worksheets("sheet2")
ws2.Cells(1, 1) = "日付"
For j = 2 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = ws1.Cells(1, j)
Next j
For j = 1 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
For i = 2 To ws1.Cells(Rows.Count, j).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Columns(1), ws1.Cells(i, j)) = 0 Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, j)
.NumberFormatLocal = "yyyy/m/d"
End With
End If
Next i
Next j
i = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Range(ws2.Cells(2, 1), ws2.Cells(i, 1)).Sort key1:=ws2.Cells(2, 1), order1:=xlAscending
For i = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
If ws2.Cells(i, 1) - ws2.Cells(i - 1, 1) > 1 Then
k = ws2.Cells(i, 1) - ws2.Cells(i - 1, 1) - 2
ws2.Rows(i & ":" & i + k).Insert
End If
Next i
For i = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws2.Cells(i, 1) = "" Then
ws2.Cells(i, 1) = ws2.Cells(i - 1, 1) + 1
End If
Next i
For j = 1 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
For i = 2 To ws1.Cells(Rows.Count, j).End(xlUp).Row
For k = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For L = 2 To ws2.Cells(1, Columns.Count).End(xlToLeft).Column
If ws1.Cells(i, j) = ws2.Cells(k, 1) And ws1.Cells(1, j + 1) = ws2.Cells(1, L) Then
ws2.Cells(k, L) = ws1.Cells(i, j + 1)
End If
Next L
Next k
Next i
Next j
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

No.6 回答者： tom04 回答日時： 2011/08/14 00:00

こんばんは！

VBAでの一例です。

無理矢理って感じです。
Sheet1のデータをSheet2に表示するようにしてみました。

Alt＋F11キー　→　画面左下にある「This workbook」をダブルクリック　→　VBE画面が出ますので
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）


Sub test() 'この行から
Dim i, j, k, L As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1") '←「sheet1」の部分は実際のSheet名に！
Set ws2 = Worksheets("sheet2")
ws2.Cells(1, 1) = "日付"
For j = 2 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = ws1.Cells(1, j)
Next j
For j = 1 To ws1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
For i = 2 To ws1.Cells(Rows.Count, j).End(xlUp).Row
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, j)
.NumberFormatLocal = "yyyy/m/d"
End With
L = ws2.Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To ws2.Cells(1, Columns.Count).End(xlToLeft).Column
If ws1.Cells(i, j) = ws2.Cells(L, 1) And ws1.Cells(1, j + 1) = ws2.Cells(1, k) Then
ws2.Cells(L, k) = ws1.Cells(i, j + 1)
End If
Next k
Next i
Next j
i = ws2.Cells(Rows.Count, 1).End(xlUp).Row
j = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
Range(ws2.Cells(2, 1), ws2.Cells(i, j)).Sort key1:=ws2.Cells(2, 1), order1:=xlAscending
For i = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
If ws2.Cells(i, 1) - ws2.Cells(i - 1, 1) > 1 Then
k = ws2.Cells(i, 1) - ws2.Cells(i - 1, 1) - 2
ws2.Rows(i & ":" & i + k).Insert
End If
Next i
For i = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws2.Cells(i, 1) = "" Then
ws2.Cells(i, 1) = ws2.Cells(i - 1, 1) + 1
End If
Next i
End Sub 'この行まで

※　For～Nextを多用していますので、時間がかかるかもしれません。
他に良い方法があればごめんなさいね。m(_ _)m

No.5 回答者： mike_g 回答日時： 2011/08/13 23:39

[No.1補足]へのコメント、

》 「1000列」で間違いありません。

そうですか。でも実際に試してみてください。
あのマンマの式で行けると思います。
縦が最大200行なら、提示式中の 10000 は 200 にしてもＯＫです。