作った表から一覧表を作成をしたい

複数店舗の人員管理をしていますが、期日内に仕事が間に合わないので、VBEで解決できる方教えてください。
下記の表を
　 A　C 　D　　 E　　 F　　G　　H　　I …
１ 　 [　 　山田　　 ][　 　佐藤　　 ]…　
２ 日 曜 応援先 入　 退　応援先 入 　退　…
３1/1 火　A店　 9:00 19:00 …
４1/2 水　　　　　　　　　　　　B店 9:00 13:00…
５1/3 木　C店　 9:00 19:00 B店 9:00 18:00…
　　　　　　　　　・
　　　　　　　　　・

このタイムカード状のシートから一覧表

　 A B C 　　D 　 E F　…
６ 日 曜　応援先 氏名 入 退　…
７1/1 火 A店 　 山田　9:00 19:00…
８1/2 水　 B店　　佐藤　9:00 13:00…
９1/3 木　 C店　　山田　9:00 19:00…
101/3 木 B店　　佐藤　9:00 18:00…
・
　　　　　　　　・

以前にも似たような質問をしたのですが、
自分ではうまく転記されません。
D1:F1,G1:I1は結合してるのですが、しない方がやりやすいのでしょうか？上の表が見にくかったらすみません。誰か回答お願いします。

No.3 ベストアンサー 回答者： pc_knight 回答日時： 2007/11/21 14:36

No2です。

作成すべき一覧表のフォーマットを誤解していました。
次のように訂正します。
Sub test1()
Dim r1 As Long
Dim r2 As Long
Dim c1 As Integer
Dim km
km = Array("日", "曜日", "応援先", "氏名", "入", "退")
Sheets("Sheet2").Cells.ClearContents
Sheets("Sheet2").Columns("A:A").NumberFormatLocal = "m/d;@" '月日(=A)列の表示形式設定
For k = 0 To 5
if k>=4 Then
Sheets("Sheet2").Cells(6, k + 1).Value = km(k) '項目名表示
Columns(n * 4 + k + 3).NumberFormatLocal = "h:mm;@" '入／退時刻列の表示形式設定
End If
Next k
For r1 = 3 To Sheets("Sheet1").Range("A65536").End(xlUp).Row '3行目から下の行に移動
For c1 = 4 To 256 Step 3 '4列目(D列)から3列おきに右の列に移動

If Sheets("Sheet1").Cells(r1, c1) <> "" Then 'r1行のそれぞれの応援先欄のセルにデータがあるなら
r2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row + 1 '書き込みセルの行No
Sheets("Sheet2").Cells(r2, 1).Value = Sheets("Sheet1").Cells(r1, 1) '日を転記
Sheets("Sheet2").Cells(r2, 2).Value = Sheets("Sheet1").Cells(r1, 3) '曜日を転記
Sheets("Sheet2").Cells(r2, 3).Value = Sheets("Sheet1").Cells(r1, c1) '応援先を転記
Sheets("Sheet2").Cells(r2, 4).Value = Sheets("Sheet1").Cells(1, c1) '氏名を転記
Sheets("Sheet2").Cells(r2, 5).Value = Sheets("Sheet1").Cells(r1, c1 + 1) '入時刻を転記
Sheets("Sheet2").Cells(r2, 6).Value = Sheets("Sheet1").Cells(r1, c1 + 2) '退時刻を転記
End If
Next c1
Next r1
msg = MsgBox(prompt:="終了しました", Buttons:=vbExclamation + vbOKOnly, Title:="")
End Sub

この回答へのお礼

親切にご回答いただきありがとうございます。
返答が遅くなり申し訳ありません。
VBEを見れば、何となく分かるのですが、VBEの組立てになると、いまいち分からなくなってしまうんですよね。(^^;)

エラー表示が出てしまったのですが、
＞If Sheets("Sheet1").Cells(r1, c1) <> "" Then 'r1行のそれぞれの応援先欄のセルにデータがあるなら

型が一致しませんと表示されてしまいました。Sheet名も合っているのですが、原因が分かりません。分かりましたらお願いします。

お礼日時：2007/11/26 16:36

No.4 回答者： pc_knight 回答日時： 2007/11/26 22:05

No.3です。

小生のパソコンではご指摘のエラーは起きませんでした。
故意にコードを変え、「型が一致しません。」エラーが起きるのか試行錯誤しましたが、「型が一致しません。」エラーが起きる要因は見つかりませんでした。
エラーメッセージ画面が出た際、「デバッグ」ボタンをクリックして見るとエラー行が黄色く色塗りされます。
「型が一致しません。」エラーが生じた際、色塗りされたのは「If Sheets("Sheet1").Cells(r1, c1) <> "" Then 'r1行のそれぞれの応援先欄のセルにデータがあるなら」の行だったでしょうか。
この行では「型が一致しません。」エラーは起きることはないように思います。
再確認をお願いします。

ただ回答したコードでは、作成したい一覧表の形式に沿っていないところがありましたので次の通り訂正します。（１０行目と１１行目の入れ替え）
（誤）
(１０行) if k>=4 Then
(１１行) Sheets("Sheet2").Cells(6, k + 1).Value = km(k) '項目名表示
（正）
(１０行) Sheets("Sheet2").Cells(6, k + 1).Value = km(k) '項目名表示
(１１行) if k>=4 Then

この回答へのお礼

遅くなり申し訳ありません。
もう一度はじめから作り直したら、うまくいきました。
ありがとうございます。

お礼日時：2007/12/20 16:31

No.2 回答者： pc_knight 回答日時： 2007/11/21 09:54

質問というより、依頼の感ですが（笑）、お困りのご様子なので・・

質問内容にて仰っている「下記の表」と作成したい「一覧表」が各シートとも一枚のシートという前提でなら、次のＶＢＡでいかがでしょう。
Sub test()
Dim r1 As Long
Dim r2 As Long
Dim c1 As Integer
Dim km
km = Array("応援先", "氏名", "入", "退")
Sheets("Sheet2").Cells.ClearContents
Sheets("Sheet2").Columns("A:A").NumberFormatLocal = "m/d;@" '月日(=A)列の表示形式設定
Sheets("Sheet2").Cells(6, 1).Value = "日"
Sheets("Sheet2").Cells(6, 2).Value = "曜日"
For n = 0 To 62
For k = 0 To 3
Sheets("Sheet2").Cells(6, n * 4 + k + 3).Value = km(k) '項目名表示
If k >= 2 Then
Columns(n * 4 + k + 3).NumberFormatLocal = "h:mm;@" '入／退時刻列の表示形式設定
End If
Next k
Next n
For r1 = 3 To Sheets("Sheet1").Range("A65536").End(xlUp).Row '3行目から下の行に移動
r2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row + 1 '書き込みセルの行Noを探し
Sheets("Sheet2").Cells(r2, 1).Value = Sheets("Sheet1").Cells(r1, 1) '日を転記
Sheets("Sheet2").Cells(r2, 2).Value = Sheets("Sheet1").Cells(r1, 3) '曜日を転記
For c1 = 4 To 256 Step 3 '4列目(D列)から3列おきに右の列に移動
If Sheets("Sheet1").Cells(r1, c1) <> "" Then '応援先が空欄でないなら
c2 = Sheets("Sheet2").Cells(r2, 256).End(xlToLeft).Column + 1 '書き込セルみ列番号を探し
Sheets("Sheet2").Cells(r2, c2).Value = Sheets("Sheet1").Cells(r1, c1) '応援先を転記
Sheets("Sheet2").Cells(r2, c2 + 1).Value = Sheets("Sheet1").Cells(1, c1) '氏名を転記
Sheets("Sheet2").Cells(r2, c2 + 2).Value = Sheets("Sheet1").Cells(r1, c1 + 1) '入時刻を転記
Sheets("Sheet2").Cells(r2, c2 + 3).Value = Sheets("Sheet1").Cells(r1, c1 + 2) '退時刻を転記
End If
Next c1
Next r1
msg = MsgBox(prompt:="終了しました", Buttons:=vbExclamation + vbOKOnly, Title:="")
End Sub

No.1 回答者： assault852 回答日時： 2007/11/20 22:06

※私の意見に対しての批判は、あえてお受け致しますが返答は致しませんので、何卒ご了承ください。

この時間まで、回答がないところを見ると、VBAで処理するにしてもかなり難しいのではないでしょうか。
よしんば、プログラムを書ける人がしたとしても、実際に検証してからでないと回答として出せないでしょうし。
あなた自身も、うまくいかないからといって、プログラムを修正するためのやり取りに時間を割くのは惜しいはず。
地道な作業で間に合わないとおっしゃるなら、間に合わないなりの仕事の進め方(善後策)があるのではありませんか。
更に個人的な意見を言わせて頂ければ、規模はわかりませんが、複数店舗の勤怠管理(就業管理)をExcelで、しかもこのような大変な思いをされて扱われているのは、非常に心苦しいです。
今はパソコンでも簡単に扱える就業管理ソフトはいくらでもありますので、御社でも是非導入を進められるように切に望みます。
※大変生意気なことを申しておりますことをお詫び致します。