[[20110107102718]]　『データーの振り分けとセルの色の反映』（くまたろう）　ページの最後に飛ぶ

　『データーの振り分けとセルの色の反映』（くまたろう）

 エクセル初心者です．らいぶらりーで似たようなものを参照してみたの
 ですがいまいち理解が出来ていないようで，うまく行きません．
 スーパー初心者で職場でエクセル２００３を使ってます．

 以下の全体スケジュールを作成して一週間の予定を組んでいるのですが，
 全体→各病棟に時間と病棟ごとに自動で振り分けることは出来ないのかとおもいまして・・

 〔全体スケジュール〕

       　　　 月曜日　　　      　火曜日　　　　　　　水曜日

   Ａ 　 Ｂ 　　Ｃ　　 Ｄ　　Ｅ　 　Ｆ　   Ｇ　　Ｈ　　 Ｉ　　 Ｊ
  時間　病棟　患者様　担当　病棟　患者様　担当　病棟　患者様　担当
  9：00　１　 澤田様 （Ｋ）  ５ 　吉田様 （Ｔ）　２ 　今井様 （Ｋ）
  9：20　２　 鎌中様 （Ｉ）　３　 高山様 （Ｋ）　３　 吉田様 （Ｓ）
  9：40　６　 澤田様 （Ｔ）　１　 石田様 （Ｔ）　７　 北村様 （Ｔ）
 10：00
 10：40

 〔１病棟〕
   Ａ　  Ｂ　　 Ｃ　 　Ｄ　  Ｅ　 　Ｆ　　 Ｇ　　Ｈ　　Ｉ　　  Ｊ　 
  時間　病棟　患者様　担当　病棟　患者様　担当　病棟　患者様　担当
  9：00　１　 澤田様　(Ｋ）　　　　　　　　　　　　　　　　　　　　　　　
  9：20　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　
  9：40　　　　　　　　　　　１　 石田様  (Ｔ）　　
 10：00
 10：40
　
 〔２病棟〕
   Ａ　　Ｂ　 　Ｃ　　 Ｄ　　Ｅ　 　Ｆ　 　Ｇ　　Ｈ　　 Ｉ　   Ｊ
  時間　病棟　患者様　担当　病棟　患者様　担当　病棟　患者様　担当
  9：00　　　　　　　　　　　　　　　　　　　　　２   今井様 （Ｋ）
  9：20　２　 鎌中様  (Ｉ）　　　　　　　　　　　　　　　　　　　　　　　
  9：40　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　
 10：00
 10：40

 というように全体→各病棟のように振り分けをしたいのですが
 なにか知恵ををかしていただける方がいたら宜しくお願い致します．

 写し取るだけで良さそうなので、IF関数でやってみるのはどうでしょう。

 〔全体スケジュール〕 										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	スケジュール									
[2]	全体	月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	（Ｋ）	5	吉田様	（Ｔ）	2	今井様	（Ｋ）
[5]	9:20	2	鎌中様	（Ｉ）	3	高山様	（Ｋ）	3	吉田様	（Ｓ）
[6]	9:40	6	澤田様	（Ｔ）	1	石田様	（Ｔ）	7	北村様	（Ｔ）
[7]	10:00									
[8]	10:40

 〔１病棟〕 										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	病棟									
[2]	1	月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	（Ｋ）						
[5]	9:20									
[6]	9:40				1	石田様	（Ｔ）			
[7]	10:00									
[8]	10:40									
B4=IF(全体スケジュール!B4=$A$2,全体スケジュール!B4,"")										
C4=IF(全体スケジュール!B4=$A$2,全体スケジュール!C4,"")										
D4=IF(全体スケジュール!B4=$A$2,全体スケジュール!D4,"")

 B4,C4,D4に数式を入れたら、3セル(B4:D4)を選択してコピー。
 数式を入れる範囲(B4:J8)を選択して　貼り付け。

 ２病棟のシートは、１病棟のシートをコピーして
 A2セルの値を変更して下さい。

 ただ、シートを大量に作らなくても
 条件付書式で要らないデータは一時的に見えなくするだけでも
 良いように思いますが。。。

 例えば、B4,C4,D4は　「=AND($A$2<>"全体",B4<>$A$2)」と言った条件で
 文字色を背景色と同じにする。
 書式を表全体にコピー。
 見たい病棟の番号をA2に入れる。
 （全て表示したい場合、今回の式では「全体」を入れる）

 (HANA)

HANAさん大変に有難うございます！さっそくやってみましたらうまくいきました！

そこで再度，ご指導いただきたいのですが・・・

例えば９：００の時間帯にどんどんスケジュールが入った場合

〔全体スケジュール〕

病棟　　　患者様　　　担当

１　　　　澤田様　　　Ｇ

２　　　　吉田様　　　Ｈ

３　　　　郷田様　　　Ｋ

５　　　　横田様　　　Ｕ

６　　　　岩井様　　　Ｐ

１　　　　与板様　　　Ｉ

〔１病棟〕

病棟　　　患者様　　　担当

１　　　　澤田様　　　Ｇ

１　　　　与板様　　　Ｉ

1病棟の患者様は表示されますが，澤田様のすぐしたに与板様とこなく

４行あけて与板様が表示されます．（他病棟の方は表示されない為

空白が沢山できます）

上に詰めて表示することは可能ですか？？

はじめからあらかじめかためて（１病棟から順に）入力すれば済みそうですが

こんどは下に空白が多くなりすぎます．

〔全体スケジュール〕

病棟　　　患者様　　　担当

１　　　　澤田様　　　Ｇ

１　　　　与板様　　　Ｉ

２　　　　吉田様　　　Ｈ

３　　　　郷田様　　　Ｋ

５　　　　横田様　　　Ｕ

６　　　　岩井様　　　Ｐ

（２，３，５，６病棟の患者様は表示されず空白が大きくなって行きます）

スケジュールがどんどん多くなると更に空白は増え，無駄に大きい

スケジュールになってしまいそうです．

どうしたら良いでしょうか？？何か知恵をお貸し下さい．

 そう言う事であれば、入力は面倒に成りますが

 〔全体スケジュール〕 									
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	
[1]	スケジュール								
[2]	全体		月曜日		火曜日		水曜日		
[3]	時間	病棟	患者様	担当	患者様	担当	患者様	担当	
[4]	9:00	1	澤田様	G					←１行の中で改行して
			良坂様	I					←２行入れる
[5]		2	吉田様	H			今井様	K	
[6]		3	郷田様	K					
[7]		4							
[8]		5	横田様	U	吉田様	T			
[9]		6	岩井様	P					
[10]		7							
[11]	9:20	1							
[12]		2	鎌中様	I					
[13]		3			高山様	K	吉田様	S	
[14]		4							
[15]		5							
[16]		6							
[17]		7							
 各時間帯で病棟毎に入力する行を決めておいて
 Alt + Enter の行内改行で追加していくことにする。

 各病棟のシートは、全体のシートの一定のセルを参照しておけば良い事に成ります。

 〔１病棟〕 								
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]
[1]	病棟							
[2]	1	月曜日		火曜日		水曜日		
[3]	時間	患者様	担当	患者様	担当	患者様	担当	
[4]	9:00	澤田様	G					
		良坂様	I					
[5]	9:20							
B4=INDEX(全体スケジュール!$C$4:$H$17,(ROW(A1)-1)*7+$A$2,COLUMN(A1))&""
 を貼り付けて、フィルドラッグ。
 セルの書式設定の配置タブで「折り返して全体を表示する」にチェックをいれておく。
 行の高さは自動で変更されないので、広めに設定しておく。

 (HANA)

 追記です。

 この表は、人が見て確認する以外の事に使用するのでしょうか？
 例えば、集計を行う（担当Aさんは何回担当したか　拾い出す）等
 有るのでしたら、1つのセルに2つ以上の情報が入っていると
 面倒な事になりそうです。

 ただ、1つのセルに1つずつ情報を入れていって、
 　病棟を指定したら、該当の情報だけを抜き出し
 　決められた時間のワク（データ量により変動）に
 　隙間無く上から順に詰めて表示し
 　しかも、情報が無い場合も時間だけは表示する
 となると、関数だけでは難しいように思います。

 (HANA)

 ＨＡＮＡさん

 アドバイス大変に有難うございました．
 そうなんです．この表は集計にも使用していますので
 １セル１情報でないと，わたしの頭がついていけません・・・

 振り分けで調べてみるとＶＢＡというのがあるようで
 それを使わないとむりですかねっ・・・

 調べてみても，何の事をいってるのかチンプンカンプン
 で・・・

 少しずつ勉強をしていこうと思います．
 数々のアドバイス大変に有難うございました！勉強になりました！

 やはり集計に使用していますか。

 でしたら、上の様に入力しておいて
 集計用のデータをマクロで作る方法も
 検討してみて下さい。

 '------
Sub データ生成()
Dim tbl As Variant
Dim spl As Variant, splK As Variant, splT As Variant
Dim i As Long, ii As Long, spi As Long
Dim mR As Long, mtR As Long
    With Sheets("全体スケジュール")
        tbl = .Cells(1, 1).Resize( _
                    .Cells(Rows.Count, 2).End(xlUp).Row, _
                    .Cells(3, Columns.Count).End(xlToLeft).Column).Value
    End With
    With Sheets("集計用データ")
        .Cells.ClearContents
        mR = 1
        .Cells(mR, 1).Resize(, 5) = Array("曜日", "時間", "病棟", "患者様", "担当")
        For i = 3 To UBound(tbl, 2) Step 2  '曜日のループ
            For ii = 4 To UBound(tbl, 1)        '曜日内のループ
                If tbl(ii, 1) <> "" Then
                    mtR = ii    '時間が入力されている行を記録
                End If
                If tbl(ii, i) <> "" Then
                    splK = Split(tbl(ii, i), vbLf)      '患者データ分割
                    splT = Split(tbl(ii, i + 1), vbLf)  '担当データ分割
                    For spi = 0 To UBound(splK, 1)
                        mR = mR + 1
                        .Cells(mR, 1).Value = tbl(2, i)     '曜日
                        .Cells(mR, 2).Value = tbl(mtR, 1)   '時間
                        .Cells(mR, 3).Value = tbl(ii, 2)    '病棟
                        .Cells(mR, 4).Value = splK(spi)     '患者様
                        .Cells(mR, 5).Value = splT(spi)     '担当
                    Next
                End If
            Next
        Next
    End With
End Sub
 '------

 以下の様なリスト形式で出力されるので、集計も簡単に成るのではないかと思います。

 〔集計用データ〕 					
	[A]	[B]	[C]	[D]	[E]
[1]	曜日	時間	病棟	患者様	担当
[2]	月曜日	9:00	1	澤田様	G
[3]	月曜日	9:00	1	良坂様	I
[4]	月曜日	9:00	2	吉田様	H
[5]	月曜日	9:00	3	郷田様	K
[6]	月曜日	9:00	5	横田様	U
[7]	月曜日	9:00	6	岩井様	P
[8]	月曜日	9:20	2	鎌中様	I
[9]	火曜日	9:00	5	吉田様	T
[10]	火曜日	9:20	3	高山様	K
[11]	水曜日	9:00	2	今井様	K
[12]	水曜日	9:20	3	吉田様	S

 (HANA)

 HANA 様

 様々ご教授頂き大変に有難うございました！！
 頂いた知恵と知識に心より感謝致します．
 おかげさまで仕事の効率が大幅にＵＰ
 するものを作ることが出来ました！！
 有難うございます！
ーーーーーーーー

 追伸：すいませんまた質問です．

 以下教えていただいたように IF関数でやってやってみたものも作成しました．このとき
 全体スケジュールの，セルを赤で塗りつぶしたとき，１病棟のシートにも色が反映される
 方法はあります？

 以下だと〔全体スケジュール〕9：00澤田様を赤にすると〔１病棟〕9：00澤田様も
 一緒に赤になるという感じですが・・・

 〔全体スケジュール〕 										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	スケジュール									
[2]	全体	月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	（Ｋ）	5	吉田様	（Ｔ）	2	今井様	（Ｋ）
[5]	9:20	2	鎌中様	（Ｉ）	3	高山様	（Ｋ）	3	吉田様	（Ｓ）
[6]	9:40	6	澤田様	（Ｔ）	1	石田様	（Ｔ）	7	北村様	（Ｔ）
[7]	10:00									
[8]	10:40

 〔１病棟〕 										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	病棟									
[2]	1	月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	（Ｋ）						
[5]	9:20									
[6]	9:40				1	石田様	（Ｔ）			
[7]	10:00									
[8]	10:40

 基本的には数式で値を参照するセルの色まで参照することはできません。
[[20020805175728]] 『参照先のセルも同時に塗りつぶす』（コルドバ）
　
エクセルは「データ」を扱うアプリケーションですが、「セルの色」は
「データ」として扱うようには設計されていない、ということです。
　
＞〔全体スケジュール〕9：00澤田様を赤にすると
「赤」にする理由が何かあるはずです。
「この患者はわがままだから対応注意」とか（笑）。
本来はセルにデータとして入力すべきことを、セルの色で代用する
形にしたいのでしょうけれども、色を判別する関数、というものが
標準では用意されていませんし、参照しているセルの色と同期する
機能もありません。
　
セルのデータがある条件のときに自動的にセルの書式を変更する
機能として条件付書式がありますが、こちらを検討されてはいかがですか？
(みやほりん)(-_∂)b

 みやほりんさん

 ありがとうございます．やはり無理ですか・・・

 条件付書式ですか？どのように設定すれば
 セルの色を他のシートに反映できますか？
 チョットやってみます・・・

 ちなみに色々調べてるうちにＶＢＡだかを
 つかえば出来るのでは？？との情報もあり
 試してみてはいるもののなかなかうまく行きません・・

 話が進んで行き気味ですが。。。

 こんなマクロなら、ご希望の様になるかもしれません。

 '------
Sub 個別スケジュール表示()
    Dim tbl As Variant, x As Variant
    Dim i As Long, ii As Long
    Dim mR As Long, mC As Long
If ActiveSheet.Name <> "個別スケジュール" Then
    MsgBox "個別スケジュール　シートをアクティブにして実行して下さい。"
    Exit Sub
End If
If Range("B1").Value = "" Then
    MsgBox "B1セルに、表示させる病棟を入力して下さい。"
    Exit Sub
End If
With Sheets("全体スケジュール")
    With .UsedRange
        mR = .Cells(.Count).Row
    End With
        mC = .Cells(3, Columns.Count).End(xlToLeft).Column
    tbl = .Cells(1, 1).Resize(mR, mC).Value

    ReDim x(1 To mR, 1 To mC + 1)
                x(1, 1) = Range("A1").Value
                x(1, 2) = Range("B1").Value
                x(1, mC + 1) = 1
    For i = 2 To 3
        For ii = 1 To mC
                x(i, ii) = tbl(i, ii)
        Next
                x(i, mC + 1) = 1
    Next
    For i = 4 To mR
        If tbl(i, 1) <> "" Then
                x(i, 1) = tbl(i, 1)
                x(i, mC + 1) = x(i, mC + 1) + 1
        End If
        For ii = 2 To mC Step 3
            If tbl(i, ii) = x(1, 2) Then
                x(i, ii) = tbl(i, ii)
                x(i, ii + 1) = tbl(i, ii + 1)
                x(i, ii + 2) = tbl(i, ii + 2)
                x(i, mC + 1) = x(i, mC + 1) + 1
            End If
        Next
    Next

    Cells.Clear
    .Range(.Cells(2, 1), .Cells(mR, mC)).Copy Cells(2, 1)
    Cells(1, 1).Resize(mR, mC + 1) = x

    Columns(mC + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns(mC + 1).Clear
End With
End Sub
 '------

 おおざっぱな説明としては
 　「全体スケジュール」シートの2行目以降を
 　「個別スケジュール」シートにコピーして
 　不要データを削除、不要行を削除
 しています。
 特に、2,3行目のデータは　そっくりコピーされますので
 不要なデータは入力しないで下さい。

 テストしたデータを載せておきます。
 [全体スケジュール]										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	全体スケジュール									
[2]		月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	K	5	吉田様	T	2	今井様	K
[5]		2	吉田様	H						
[6]		3	郷田様	K						
[7]		5	横田様	U						
[8]		6	岩井様	P						
[9]		1	与板様	I						
[10]	9:20	2	鎌中様	I	3	高山様	K	3	吉田様	S
[11]	9:40	6	澤田様	T	1	石田様	T	7	北村様	T
[12]	10:00									
 これで、B9:D9セルを「赤」で塗ってみました。

 個別スケジュールシートのB1セルに「1」を入力して　マクロを実行。
 [個別スケジュール]										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	病棟	1								
[2]		月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	K						
[5]		1	与板様	I						
[6]	9:20									
[7]	9:40				1	石田様	T			
[8]	10:00									
 B5:D5セルに色が付いている状態です。

 そう言えば、この掲示板の使い方ですが、
 投稿文を書く時に
_←ここに半角スペースを入れると
 改行を挟まなくても、改行されます。

 (HANA)

 今と成ってはどうでも良いことなんですが
 やはり心残りなので、書いておきます。。。

 最初にのせた「データ生成」マクロですが
 spl As Variant,　を消し忘れてました。。。

 上から３行目
Dim spl As Variant, splK As Variant, splT As Variant
 ↓
Dim splK As Variant, splT As Variant

 まぁ、動きには関係ないんですけどね。。。

 (HANA)

 ＨＡＮＡ　様

 一番最初に教えて下さったＩＦ関数で作ったものに
 教えて頂いたマクロを入れて実行したところ
 他の病棟の塗りつぶしたところも表示されます．
 何か改善策はありますか？

 以下の感じになります．

 シート〔全体スケジュール〕の９：２０鎌中様〔Ｂ５：Ｄ５〕を赤に塗りつぶすと
 シート〔１病棟〕9：20の空欄の〔Ｂ５：Ｄ５〕も赤に塗りつぶされます．

 １病棟には関係ない部分が塗りつぶされます．塗りつぶしを避けたいのですが・・・

〔全体スケジュール〕

	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	スケジュール									
[2]	全体	月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	（Ｋ）	5	吉田様	（Ｔ）	2	今井様	（Ｋ）
[5]	9:20	2	鎌中様	（Ｉ）	3	高山様	（Ｋ）	3	吉田様	（Ｓ）
[6]	9:40	6	澤田様	（Ｔ）	1	石田様	（Ｔ）	7	北村様	（Ｔ）
[7]	10:00									
[8]	10:40

 〔１病棟〕 										
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	病棟									
[2]	1	月曜日			火曜日			水曜日		
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
[4]	9:00	1	澤田様	（Ｋ）						
[5]	9:20									
[6]	9:40				1	石田様	（Ｔ）			
[7]	10:00									
[8]	10:40

（くまたろう）

 すみません、先ほどのコードは基本的に駄目ですね。。。
 これも不安が残りますが、一応修正版を作ったので、
 こちらで試してもらえますか？

 '------
Sub 個別スケジュール表示2()
    Dim tbl As Variant, x As Variant, y As Variant
    Dim dK As Variant
    Dim dic As Object
    Dim i As Long, ii As Long
    Dim mR As Long, mC As Long, xR As Long
Set dic = CreateObject("scripting.dictionary")
If ActiveSheet.Name <> "個別スケジュール" Then
    MsgBox "個別スケジュール　シートをアクティブにして実行して下さい。"
    Exit Sub
End If
If Range("B1").Value = "" Then
    MsgBox "B1セルに、表示させる病棟を入力して下さい。"
    Exit Sub
End If
With Sheets("全体スケジュール")
    With .UsedRange
        mR = .Cells(.Count).Row
    End With
        mC = .Cells(3, Columns.Count).End(xlToLeft).Column
    tbl = .Cells(1, 1).Resize(mR, mC).Value

    ReDim x(1 To mR, 1 To mC)
    ReDim y(1 To 1, 1 To mC)

                x(1, 1) = Range("A1").Value
                x(1, 2) = Range("B1").Value
                y(1, 1) = 3
    For i = 2 To 3
        For ii = 1 To mC
                x(i, ii) = tbl(i, ii)
        Next
    Next
    For i = 4 To mR
        If tbl(i, 1) <> "" Then
                y(1, 1) = y(1, 1) + 1
                xR = y(1, 1)
                x(xR, 1) = tbl(i, 1)
            For ii = 2 To mC Step 3
                y(1, ii) = y(1, 1)
            Next
        End If
        For ii = 2 To mC Step 3
            If tbl(i, ii) = x(1, 2) Then
                xR = y(1, ii)
                x(xR, ii) = tbl(i, ii)
                x(xR, ii + 1) = tbl(i, ii + 1)
                x(xR, ii + 2) = tbl(i, ii + 2)
                y(1, 1) = Application.Max(y(1, 1), y(1, ii))
                y(1, ii) = y(1, ii) + 1
                dK = .Cells(i, ii).Interior.ColorIndex
                If dK <> xlNone Then
                    dic(dK) = dic(dK) & "," & .Cells(xR, ii).Resize(1, 3).Address(0, 0)
                End If
            End If
        Next
    Next
End With
Application.ScreenUpdating = False
    Cells.Clear
    Cells(1, 1).Resize(mR).NumberFormatLocal = "h:mm;@"
    Cells(1, 1).Resize(mR, mC) = x
    For Each dK In dic.Keys
        Range(Right(dic(dK), Len(dic(dK)) - 1)).Interior.ColorIndex = dK
    Next
Application.ScreenUpdating = True
Set dic = Nothing
End Sub
 '------

 ちなみに、A2セルは空欄にしておいてもらうのが良いと思います。

 (HANA)

 HANA 様

 有難うございます！さっそくコピーペーストし
 ためしてみましたがインデックスが有効範囲にありません
 というメッセージが出てうまく働きません．
 Ａ２は空白にしてみましたが・・・

 （くまたろう）

 メッセージボックスのボタンに
   [ 継続(C) ] [ 終了(E) ] [ デバッグ(D) ] [ ヘルプ(H) ]
 と4つ有ると思いますが、「デバッグ」ボタンを押した時に
 コード内で黄色くハイライトされる行を
 教えて下さい。

 (HANA)

 ＨＡＮＡ様

 ーMicrosoft visual Basicー
 インデックスが有効な範囲内にありません
 　　　Ｏ．Ｋ　　　　ヘルプ

 の二つのボタンしかありませんが？

 何かまちがった操作をしてますかね・・？

 （くまたろう）

 コードはどこに書いてありますか？

 標準モジュール？

 (HANA)

 HANA様

 コードはTHISWORKBOOK というところにかいてました。

 標準モジュールというところに書くと４つボタンが
 出てきて、デバックを押すと以下x(xR, ii) = tbl(i, ii)の部分
 以下←で表示のところが黄色に表示されました。
 いかがでしょうか？？

Sub 個別スケジュール表示2()

    Dim tbl As Variant, x As Variant, y As Variant
    Dim dK As Variant
    Dim dic As Object
    Dim i As Long, ii As Long
    Dim mR As Long, mC As Long, xR As Long
Set dic = CreateObject("scripting.dictionary")
If ActiveSheet.Name <> "個別スケジュール" Then
    MsgBox "個別スケジュール　シートをアクティブにして実行して下さい。"
    Exit Sub
End If
If Range("B1").Value = "" Then
    MsgBox "B1セルに、表示させる病棟を入力して下さい。"
    Exit Sub
End If
With Sheets("全体スケジュール")
    With .UsedRange
        mR = .Cells(.Count).Row
    End With
        mC = .Cells(3, Columns.Count).End(xlToLeft).Column
    tbl = .Cells(1, 1).Resize(mR, mC).Value

    ReDim x(1 To mR, 1 To mC)
    ReDim y(1 To 1, 1 To mC)

                x(1, 1) = Range("A1").Value
                x(1, 2) = Range("B1").Value
                y(1, 1) = 3
    For i = 2 To 3
        For ii = 1 To mC
                x(i, ii) = tbl(i, ii)
        Next
    Next
    For i = 4 To mR
        If tbl(i, 1) <> "" Then
                y(1, 1) = y(1, 1) + 1
                xR = y(1, 1)
                x(xR, 1) = tbl(i, 1)
            For ii = 2 To mC Step 3
                y(1, ii) = y(1, 1)
            Next
        End If
        For ii = 2 To mC Step 3
            If tbl(i, ii) = x(1, 2) Then
                xR = y(1, ii)
                x(xR, ii) = tbl(i, ii)←ここが黄色く表示
                x(xR, ii + 1) = tbl(i, ii + 1)
                x(xR, ii + 2) = tbl(i, ii + 2)
                y(1, 1) = Application.Max(y(1, 1), y(1, ii))
                y(1, ii) = y(1, ii) + 1
                dK = .Cells(i, ii).Interior.ColorIndex
                If dK <> xlNone Then
                    dic(dK) = dic(dK) & "," & .Cells(xR, ii).Resize(1, 3).Address(0, 0)
                End If
            End If
        Next
    Next
End With
Application.ScreenUpdating = False
    Cells.Clear
    Cells(1, 1).Resize(mR).NumberFormatLocal = "h:mm;@"
    Cells(1, 1).Resize(mR, mC) = x
    For Each dK In dic.Keys
        Range(Right(dic(dK), Len(dic(dK)) - 1)).Interior.ColorIndex = dK
    Next
Application.ScreenUpdating = True
Set dic = Nothing
End Sub

 何ですかねぇ。。。

 お手数ですが、新しいブックを用意して
 新しいシートに　こちらに載せておられる表と同じ表を作成
 　（ここからコピーして、A1セルを選択して右クリック
 　　形式を選択して貼り付け→テキスト　で貼り付けた後
     行列番号の行列を削除して作成してもらっても良いです。）
 して、シート名等あわせて
 マクロを実行してみてもらえませんか？
 （コードは、標準モジュールに置いてください。）

 こちらでは動いてしまうので、原因がつかめないでいます。

 また、テストしているシートと同じシートをこちらでも作成できるように
 情報を頂けると良いのですが。
 　全体スケジュールシートの、A1:J8以外に　何が入力があるか。
 　個別スケジュールシートの、B1に　病棟が正しく入っているか。

 (HANA)

 HANA　様

 指定された方法で試したら確かに出来ました・・
 しかし自分のテストしているシートで試したら
 同じメッセージが出ました。

 自分がテストしているシートをここに貼り付けたのですが
 （エクセルからコピーペースト）

 表示をみたらばらばらになってうまく貼り付けられません・・・

 とりあえず以下なんですが・・・すいません。さらに１７：００まで
 つづきますが、収集がつかなくなるので半分だけコピーペースト
 してみました。

スケジュール ※１Ｆリハ室の時間帯でベッドサイドに行く場合は①　②　③　⑤　⑥　⑦　で病棟を記入 2011年1月17日
全体月火水木金土
9:00 2 熊谷　洋一Ｂ Km 熊 As 足 As 足 As 足 As 足 As

	1	佐々木　正Ｂ	Km	熊	3	三上　信B	Km	熊	2	日向　昌雄Ｂ	Km	熊	6	秋山　良二Ｂ	Km	熊	2	日向　昌雄Ｂ	Km	熊			Km
	3	藤原　隆兵B	Tk	高	1	石原　政Ｂ	Tk	高	1	金内　幸一Ｂ	Tk	高	3	高橋　清B	Tk	高	1	大関　アエ子B	Tk	高			Tk
	1	武市　孫六B	Iz	崎	7	石川　ナツ子	Iz	崎	2	出田　宗雄B 	Iz	崎	6	近江　キミ子B	Iz	崎	5	野田　トミ雄B	Iz	崎	7	沼田　健二B	Iz
	1	田中　英似B	Iz	東				東	1	山岸　ヤイ子B		東	6	煤谷　貞雄B	宮	東	5	山本　文一B		東	5	越後屋　重雄B	
	2	佐藤　盛文B	宮	村	2	菅井　フサB	Km	村	3	本間　岩一B	宮	村	2	大住　和B	Iz	村			Km	村			
	6	小林　トシ子B	In	井	6	鈴木　忠雄Ｂ	In	井	3	木村　耕二Ｂ	In	井	1	山本　幸一Ｂ	In	井	1	岩澤　ツ美B	In	井	3	加藤　正一B	In
9:20	6	松川　美代	As	足	5	佐藤　久仁	As	足	6	松川　美代	As	足	6	松川　美代	As	足	5	荒井　勝一	As	足	6	松川　美代	As
	3	高山　康宏	Km	熊	2	荒沢　良子	Km	熊	2	菅　満二	Km	熊			Km	熊	①	北村　善一Ｂ	Km	熊	5	田岡　ユキ子	Km
	1	大崎　隆二	Tk	高	2	菅　満二	Tk	高	5	金住　エシ子	Tk	高	1	山田　栄一	Tk	高	2	菅　満二	Tk	高	6	石神　孝一	Tk
	5	田岡　ユキ子	Iz	崎	5	金住　エシ子	Iz	崎	5	佐藤　キイ汰	Iz	崎	6	佐藤　富一	Iz	崎	1	西田　はつ	Iz	崎	6	川崎　憲	Iz
	①	佐倉井　榮美子	In	井	②	小西　勇吉B	In	井	6	矢野　廣美	In	井	7	森山　さよ子	In	井	6	矢野　廣美	In	井	②	川村　みよB	In
	5	宮下　永	宮	東	5	宮下　永二	Km	東	2	鈴木　和雄	Km	東	3	川合　良二	宮	東	1	守屋　ミツ雄		東	2	荒澤　良二	宮
	3	早阪　つや	Km	村	2	荻田　なみ		村	7	白田　千代	宮	村	1	稲田　テル雄	Kw	村	3	早阪　つや	Km	村	①	坂上　ハナB	Iz

10:00 1 大嶋　武 As 足 5 荒井　勝三 As 足 5 佐藤　笑子 As 足 1 大嶋　武 As 足 As 足 As

					7	永田　忍子	Km	熊	1	駒澤　伸一	Km	熊	5	小嶋　君尾	Km	熊	2	脇田　勲一	Km	熊			Km
	5	佐藤　久仁	Tk	高	5	田岡　ユキ子	Tk	高	3	水戸　和子	Tk	高	6	大柳　末吉	Tk	高	6	佐藤　富一	Tk	高			TK
	外	須佐　律子	Iz	崎	1	小野　登美	Iz	崎	5	和田　エミ子	Iz	崎	5	西川　昭吉	Iz	崎	⑦	飯田　容美B⑦寺崎カツ美Ｂ	Iz	崎			Iz
	1	佐野　松美	In	井	外	菊地　勘二	In	井	7	永田　忍一	In	井	3	伊藤　静雄	In	井	6	檜山　キヨ	In	井			In
	5	金住　エシ子	宮	東	5	小原　浪兵	宮	東	6	丸藤　テル雄	Km	東	1	田中　英一	宮	東	2	七戸　八尾	Km	東			
	1	西田　はつ		村	5	横関　千代	Km	村	1	中山　郁二	宮	村	6	明珍　ツエ	Iz	村	5	佐藤　久仁	Kw	村			
																			Iz	崎			
10:40	③	杉本　フイB	As	足	2	丸藤　義二	As	足	③	杉本　フイB	As	足	5	富岡　房一	As	足			As	足	5	佐藤　笑美	As
	2	鎌中　和雄	Km	熊	5	北濱　悦	Km	熊	①	北村　善一Ｂ	Km	熊	⑤	佐々木　幸一B	Km	熊	7	川島　誠一	Km	熊	2	鎌中　和雄	Km
	外	須佐　律子	Tk	高	5	西川　昭兵	Tk	高	2	小林　芳一	Tk	高	1	佐野　松一	Tk	高	2	伊東　正一	Tk	高			Tk
	5	佐々木　ユリ子	Iz	崎	3	宮崎　静薫	Iz	崎	1	坂上　ハナ	Iz	崎	1	伊藤　テイ子	Iz	崎	6	明珍　ツエ	Iz	崎	7	高島　ユリ	Iz
	3	谷澤　節	In	井	6	大柳　末吉	In	井	②	川村　みよB	In	井	1	金内　幸一	In	井	3	谷澤　節美	In	井	3	谷澤　節子	In
	2	小林　芳子	Tk	東	2	七戸　由造		東	1	守屋　ミツ雄		東	3	谷澤　節	In	東	3	中山　貞		東			
	5	太田　作雄	宮	村	7	白田　千代		村	5	太田　作一	宮	村	⑥	佐藤　卓雄Ｂ	宮	村	2	宮田　靖一	Km	村	⑥	煤谷　貞雄B	km
																					2	宮田　靖雄	宮
11:20	5	佐藤　百合B（前半）	As	足	3	後藤　光B　（前半）	As	足	5	村上　洋智B（前半）	As	足	5	佐藤　百合B（前半）	As	足	5	村上　洋一B	As	足			As
									1	佐藤　保一Ｂ（前半）	Km	熊			As	足	2	出田　宗雄Ｂ（前半）	Km	熊			
	2	出田　宗雄Ｂ（前半）	Km	熊	1	佐藤　保一（前半）	Km	熊	1	石原　政子B（後半）	Km	熊	1	佐藤　保一（前半）	Km	熊	1	石原　政一B（後半）	Km	熊	5	高橋　博一B	Km
	1	石原　政B（後半）	Km	熊	1	佐々木正（後半）	Km	熊	1	駒澤　伸一B（前半）	Tk	高	1	佐々木　正（後半）	Km	熊	5	三住　宏一B（前半）	Tk	高	2	出田　宗雄B	Tk
	5	高橋　博B（前半）	Tk	高	2	長田　千寿B（前半）	Tk	高	7	石川　ナツ美B(後半)	Tk	高	1	山田　英一(前半)	Tk	高	5	西川　昭一B（後半）	Tk	高	5	野田　トミ子B	Iz
	7	武田　豊子(後半)	Tk	高	3	川合　良雄B(後半)	Tk	高			Iz	崎	6	古西　高(後半)	Tk	高	1	石原　政雄B（前半)	Iz	崎	5	富川　すま太郎B	In
	3	古木　秋子B(前半)	Iz	崎	1	佐々木　正(前半)	Iz	崎	2	渡辺　志げB(後半)	Iz	崎	1	佐々木　正(前半)	Iz	崎			Iz	崎			
			Iz	崎	7	對馬　清B(後半)	Iz	崎	5	富川　すまB（前半）	In	井	7	對馬　清B(後半)	Iz	崎	5	志村　金一B(前半)	In	井			
	3	平間　セツB(前半)	In	井	1	大友　タヨ美B	In	井	6	小林　トシ雄B（後半）	In	井	3	加藤　正一B(前半）	In	井	6	鈴木　忠雄B（後半）	In	井			
	3	佐倉井　神事B（後半）	In	井			In	井	7	紙谷登代Ｂ	宮	宮	3	木村　耕一Ｂ（後半）	In	井							
12:00	7	佐藤　源B	宮	宮									2	福屋　好汰Ｂ	宮	宮

 シートの状態のご説明、ありがとうございます。

 エラーが出る原因は、3行目に
[3]	時間	病棟	患者様	担当	病棟	患者様	担当	病棟	患者様	担当
 と言った見出しがないためです。
 （4行目がデータの先頭行だと思っているのに、そうでないため。）

 １．3行目に一行挿入して　4行目（A4）に「9:00」となる様にする
 ２．一つの曜日が 4列に成っている様だが、これをとりあえず 3列にする
 ３．3行目を見出しで埋めるか、最後の列のセル（S3 ？）に何か入力をする

 と、動くようになると思います。

 動いたら、実際のシートの状態に　マクロを合わせて行きたいと思います。
 　１．見出しはないのか？
 　２．データは3行目からか？
 　３．一つの曜日は4列毎か？
 　４．病棟「1」を指定した時に「①」も一緒に選ぶか？
 等です。

 問題点、希望との相違点　を挙げてみて頂ければと思います。

 (HANA)

 本題と関係ないことですが、上記のデータって実在の名前ではないですよね。
 個人情報の取り扱いにはいろいろと問題のある昨今ですので、老婆心ながら・・・。
 (Mook)

 HANA 様

 ありがとうございます．教えて下さったようにやりました．

 病棟，時間ごとに表示はされるようになりましたが・・・
 ①罫線が全て消えてしまい，書式が変わってしまいます．
 ②塗りつぶしの色はごく一部しか反映されていないです．
 書式や罫線もそのままで，色を反映するのは難しいですかね？

 追伸：シートの患者様名は全て想像上の名前です．

 （くまたろう）

 罫線はどこにどの様な罫線が引いてありますか？
 書式はどこにどの様な設定がありますか？
 （規則性・法則等が有れば、簡単なのですが。）

 塗りつぶしの色は、具体的にどのセルに塗ってありますか？

 現在のコードは、全体スケジュールの病棟の列のセルの色だけを確認
 （続く２セルは同じ色が設定されているものと）して、病棟シートに再現しています。

 その他の書式や罫線は、引き継ぐ様にはなっていません。

 詳しい状況が分かれば、何とかなるかもしれません。
 。。。何ともならないかもしれませんが。。。。

 (HANA)

 HANA 様

 どうもうまく入力出来ず
 ここの掲示板で表現するのは自分には限界なんで・・・
 以下よろしくお願い致します．
 全体スケジュールと個別スケジュールがそれです．
 ※例として１病棟を指定したときのイメージです．
http://www.filebank.co.jp/guest/seiichikuma/fp/new

 くまたろう

 ファイル確認しました。
 ・・・上に詰めれば良いんですよね？

 1曜日　2列バージョンです。
 1列目のセルの色（が続くセルにも）と
 無理矢理ですが、太字の書式設定が引き継がれます。

 '------
Sub 個別スケジュール表示3()
    Dim tbl As Variant, x As Variant, y As Variant
    Dim dK As Variant
    Dim dic As Object
    Dim i As Long, ii As Long
    Dim mR As Long, mC As Long, xR As Long
Set dic = CreateObject("scripting.dictionary")
If ActiveSheet.Name <> "個別スケジュール" Then
    MsgBox "個別スケジュール　シートをアクティブにして実行して下さい。"
    Exit Sub
End If
If Range("B1").Value = "" Then
    MsgBox "B1セルに、表示させる病棟を入力して下さい。"
    Exit Sub
End If
With Sheets("全体スケジュール")
    With .UsedRange
        mR = .Cells(.Count).Row
    End With
        mC = .Cells(3, Columns.Count).End(xlToLeft).Column
    tbl = .Cells(1, 1).Resize(mR, mC).Value

    ReDim x(1 To mR, 1 To mC)
    ReDim y(1 To 1, 1 To mC)

        For ii = 1 To mC
            If IsDate(tbl(1, ii)) Then
                x(1, ii) = tbl(1, ii)
            End If
        Next
    For i = 2 To 3
        For ii = 1 To mC
                x(i, ii) = tbl(i, ii)
        Next
    Next
                x(1, 1) = Range("A1").Value
                x(1, 2) = Range("B1").Value
                y(1, 1) = 3
    For i = 4 To mR
        If tbl(i, 1) <> "" And tbl(i, 1) <> "時間" Then
                y(1, 1) = y(1, 1) + 1
                xR = y(1, 1)
                x(xR, 1) = tbl(i, 1)
            For ii = 2 To mC Step 2
                y(1, ii) = y(1, 1)
            Next
        End If
        For ii = 2 To mC Step 2
            If tbl(i, ii) = x(1, 2) Then
                xR = y(1, ii)
                x(xR, ii) = tbl(i, ii)
                x(xR, ii + 1) = tbl(i, ii + 1)
                y(1, 1) = Application.Max(y(1, 1), y(1, ii))
                y(1, ii) = y(1, ii) + 1
                dK = .Cells(i, ii).Interior.ColorIndex
                If dK <> xlNone Then
                    dic(dK) = dic(dK) & "," & .Cells(xR, ii).Resize(1, 2).Address(0, 0)
                End If
                dK = .Cells(i, ii).Font.Bold
                If dK Then
                    dic("FB") = dic("FB") & "," & .Cells(xR, ii).Address(0, 0)
                End If
                dK = .Cells(i, ii + 1).Font.Bold
                If dK Then
                    dic("FB") = dic("FB") & "," & .Cells(xR, ii + 1).Address(0, 0)
                End If

            End If
        Next
    Next
End With
Application.ScreenUpdating = False
    Cells.Clear

    With Cells(2, 2).Resize(1, 2)
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        .Copy
    End With
        Cells(2, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

    With Cells(3, 2).Resize(1, 2)
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        .Copy
    End With
        Cells(3, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

    With Cells(4, 2).Resize(1, 2)
        With .Borders(xlEdgeTop)
            .LineStyle = xlDot
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlDot
            .Weight = xlThin
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        .Copy
    End With
        Cells(4, 2).Resize(y(1, 1) - 3, mC - 1).PasteSpecial Paste:=xlPasteFormats

    For i = 4 To y(1, 1)
        If x(i, 1) <> "" Then
            With Cells(i, 2).Resize(1, mC - 1)
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
            End With
        End If
    Next
            With Cells(i, 2).Resize(1, mC - 1)
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
            End With
    For Each dK In dic.Keys
        If dK = "FB" Then
            Range(Right(dic(dK), Len(dic(dK)) - 1)).Font.Bold = True
        Else
            Range(Right(dic(dK), Len(dic(dK)) - 1)).Interior.ColorIndex = dK
        End If
    Next
    Cells(1, 1).Resize(mR).NumberFormatLocal = "h:mm;@"
    Cells(1, 1).Resize(mR, mC) = x
    Cells(1, 1).Select
Application.ScreenUpdating = True
Set dic = Nothing
End Sub
 '------

 (HANA)

 HANA様

 いつもありがとうございます！かなり目指していたものに近づきました！
 感謝いたします！

 以下細かい部分ですがご教授よろしくお願い致します．

 ①個別スケジュールの列幅や行幅を変えてもそのまま保存され
 ますが文字の大きさは表示させるたびに１１ポイントに戻ります．
 これを１２ポイントや１３ポイントと変更をしたのちも
 そのまま生きる設定は可能ですか？

 ②１～７病棟のそれぞれシートを作り
 （個別スケジュール１病棟，個別スケジュール２病棟・・・個別スケジュール７病棟），
 マクロを実行し，同時に１～７病棟をそれぞれのシートに表示させることは出来ますか？

 ③１つのシートで２つの病棟のスケジュールを表示させる事は可能ですか？　
 （具体的には１・２病棟，３・７病棟，５・６病棟とシートを別に作成したいです）
 （そのときは例えば９時の枠に１病棟２病棟を一緒に表示させたいです）

 どうでしょう？

 くまたろう

 (1)に関してですが
 　フォントサイズは、個別シートの方に列毎に指定するという事ですか？
 　それとも、太字の様に　全体スケジュールの書式を引き継ぐ　という事ですか？

 　前者でしたら、簡単に出来ますが
 　後者でしたら、今後の課題にして下さい。

 　また、列幅は引き継がなくて良いのですか？

 その他に関しては以下の様にして下さい。

 １．標準モジュールを追加して（Module2）以下のコードを貼り付け。
 '===========================
 '　2011.01.21 コード変更1
 '===========================
 '------
Sub スケジュール表示(ByVal AShN As String, ByVal mSh As String, ByVal mBt As String, _
                        ByVal mR As Long, ByVal mC As Long, ByVal wC As Long)
    Dim tbl As Variant, x As Variant, y As Variant, mBt1 As Variant
    Dim dK As Variant
    Dim dic As Object
    Dim i As Long, ii As Long, iii As Long
    Dim xR As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets(AShN)
        tbl = .Cells(1, 1).Resize(mR, mC).Value

        ReDim x(1 To mR, 1 To mC)
        ReDim y(1 To 1, 1 To mC)

            For ii = 1 To mC
                If IsDate(tbl(1, ii)) Then
                    x(1, ii) = tbl(1, ii)
                End If
            Next
        For i = 2 To 3
            For ii = 1 To mC
                    x(i, ii) = tbl(i, ii)
            Next
        Next
                    y(1, 1) = 3
        For i = 4 To mR
            If tbl(i, 1) <> "" And tbl(i, 1) <> "時間" Then
                    y(1, 1) = y(1, 1) + 1
                    xR = y(1, 1)
                    x(xR, 1) = tbl(i, 1)
                For ii = 2 To mC Step 2
                    y(1, ii) = y(1, 1)
                Next
            End If
            For ii = 2 To mC Step wC
                For Each mBt1 In Split(mBt, "/")
                    If CStr(tbl(i, ii)) = mBt1 Then
                        xR = y(1, ii)

                        y(1, 1) = Application.Max(y(1, 1), y(1, ii))
                        y(1, ii) = y(1, ii) + 1

                        For iii = 1 To wC
                            x(xR, ii + iii - 1) = tbl(i, ii + iii - 1)
                            dK = .Cells(i, ii + iii - 1).Font.Bold
                            If dK Then
                                dic("FB") = dic("FB") & "," & .Cells(xR, ii + iii - 1).Address(0, 0)
                            End If
                        Next

                        dK = .Cells(i, ii).Interior.ColorIndex
                        If dK <> xlNone Then
                            dic(dK) = dic(dK) & "," & .Cells(xR, ii).Resize(1, wC).Address(0, 0)
                        End If

                    End If
                Next
            Next
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets(mSh)
        .Cells.Clear

        Call 基本書式(AShN, mSh, mC, wC, y(1, 1))

        For i = 4 To y(1, 1)
            If x(i, 1) <> "" Then
                With .Cells(i, 2).Resize(1, mC - 1)
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                    End With
                End With
            End If
        Next
        For Each dK In dic.Keys
            If dK = "FB" Then
                .Range(Right(dic(dK), Len(dic(dK)) - 1)).Font.Bold = True
            Else
                .Range(Right(dic(dK), Len(dic(dK)) - 1)).Interior.ColorIndex = dK
            End If
        Next
        .Cells(1, 1).Resize(mR, mC) = x
        Application.Goto (.Cells(1, 1))
    Application.ScreenUpdating = True
    End With
Set dic = Nothing
End Sub
 '------
Sub 基本書式(ByVal AShN As String, ByVal mSh As String, ByVal mC As Long, ByVal wC As Long, ByVal mR As Long)
    With Sheets(mSh)
        Sheets(AShN).Rows(1).Copy .Cells(1, 1)
        .Rows(1).Interior.ColorIndex = xlNone

        With .Cells(2, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            .Copy
        End With
            .Cells(2, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(3, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy
        End With
            .Cells(3, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(4, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlDot
                .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlDot
                .Weight = xlThin
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy
        End With
            .Cells(4, 2).Resize(mR - 3, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(mR + 1, 2).Resize(1, mC - 1)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With

        With .Cells.Font
            .Name = "ＭＳ 明朝"
            .Size = 13
        End With

        .Cells(1, 1).Resize(mR).NumberFormatLocal = "h:mm;@"
    End With
End Sub
 '------

 ２．別の標準モジュール（Module1）に、以下のコードを貼り付け。
 '------
Sub 個別2列()
    Const wC As Long = 2
    Const AShN As String = "全体スケジュール"
    Const ShN As String = "1BT_2BT"
    Const BtN As String = "1/2_3"

    Dim ShA As Variant, BtA As Variant
    Dim mR As Long, mC As Long
    Dim i As Long, Li As Long
    With Sheets(AShN)
        With .UsedRange
            mR = .Cells(.Count).Row
        End With
            mC = .Cells(3, Columns.Count).End(xlToLeft).Column
    End With
    ShA = Split(ShN, "_")
    BtA = Split(BtN, "_")
    For Li = 0 To UBound(ShA, 1)
        Call スケジュール表示(AShN, ShA(Li), BtA(Li), mR, mC, wC)
    Next
    Application.Goto (Sheets(AShN).Cells(1, 1))
End Sub
 '------

 ３．「個別2列」マクロを実行前に　シートを二枚追加し
 　　それぞれ　1BT 2BT　と名前を付けておく。

 ４．で、マクロを実行してみてください。

 他の様式を処理する場合は「個別2列」マクロの上の方にある
    Const wC As Long = 2　・・・・・・・・・・・・(1)
    Const AShN As String = "全体スケジュール" ・・(2)
    Const ShN As String = "1BT_2BT" ・・・・・・・(3)
    Const BtN As String = "1/2_3" ・・・・・・・・(4)
 を変更してください。

 (1)一つの曜日の列数を入力してください。
 (2)元となるデータがあるシート名を指定してください。
 (3)個別シートのシート名を「_（アンダーバー）」で区切って入力してください。
 (4)抽出したい病棟番号を　(3)と対応する順番で「_（アンダーバー）」で区切って入力してください。
    　　二つ以上を指定したい場合は、「/（スラッシュ）」で区切って入力してください。

 「個別2列」マクロは、
 一つの曜日が2列ずつで入力されている
 全体スケジュール　という名前のシートから
 1BTシートには、病棟番号が 1 と 2 のものを。
 2BTシートには、病棟番号が 3 のものを抽出します。

 間で載せて下さったサンプルデータの様に
 一つの曜日が4列のものも処理する場合は
 Module1　にはりつけたコードを複製して
 マクロ名と曜日の列数（等）を変更してください。
Sub 個別4列()　　　　　　★マクロ名の変更と
    Const wC As Long = 4 ★曜日列数の変更
    Const AShN As String = "全体スケジュール"
    Const ShN As String = "1BT_2BT"
    Const BtN As String = "1/2_3"

 ちなみに、エラー処理が入っていませんので想定外のデータが入っていると
 止まる可能性があります。

 また、書式の設定が（と言っても、セルの色と太字しか見てませんが）多いと
 これまたエラーに成る可能性がありますので、そのあたりは
 頭の片隅にでも　置いて於いて頂ければと思います。

 (HANA)

HANA 様

早速，試してみました．本当に有難うございます！

(1)に関してですが

 　フォントサイズは、個別シートの方に列毎に指定したものが
　　マクロ実行後にも生きればありがたいです．
　　ちなみにフォントサイズの他にも書体や太字等も指定したりできますか？
　　エラーの可能性が↑するとのことですが・・・もし可能なら
　　どのようにしたら出来るのかなとおもいまして．

※列幅は全体から反映されないほうが理想です．

理想のものが出来てきました！本当に有難うございます！

くまたろう

 動きましたか。。。良かったです。

 もしかして、太字も　全体スケジュールから引き継ぐのではないのですか？
 セルの色は、全体スケジュールから引き継ぐのですよね？

 基本的には、（基本書式）の
 　With .Cells(2, 2).Resize(1, wC)
 　　のくくりで、2行目（曜日の行）のワク線
 　With .Cells(3, 2).Resize(1, wC)
 　　のくくりで、3行目（見出しの行）のワク線
 　With .Cells(4, 2).Resize(1, wC)
 　　のくくりで、4行目以降（実際のデータ範囲）のワク線
 　　　　　　　　但し、横線時間毎の太線は別途
 を書いています。

 このWith ～ End With の中では、月曜日の最初のセル群にのみ設定をして
 それぞれのWith の後にある
 　○○.PasteSpecial Paste:=xlPasteFormats
 で、その書式を、他の曜日のセルに貼り付けています。

 この行の前までに（実際には .Copy の前ですが）
 該当部分のフォントの設定をする様にしておけば
 良いのではないかと思います。

 ただし、太字に関しては　全体スケジュールから引き継ぐ様に成っているので
 コードの該当部分は、削除が必要に成ってくると思います。

 (HANA)

HANA 様

有難うございます！

太字は全体スケジュールから引き継げました．

セルの色も全体スケジュールから引き継ぐ

ようになってます．有難うございす！

そこで教えていただいたように

以下試してみましたが分からないことが・・・

（１）

Module1　にはりつけたコードを複製して

 マクロ名と曜日の列数（等）を変更してください。
Sub 個別4列()　　　　　　★マクロ名の変更と
    Const wC As Long = 4 ★曜日列数の変更
    Const AShN As String = "全体スケジュール"
    Const ShN As String = "1BT_2BT"
    Const BtN As String = "1/2_3"

↓↓↓

１列目　　２列目　　３列目　　　４列目
病棟　　　患者様　　　

と３列目，４列目が全体スケジュールから引き継がれません．

また

Sub 個別2列()　　　　　　

    Const wC As Long = 2

にした時と

Sub 個別4列()　　　　　　

    Const wC As Long = 4

にした時に個別スケジュールに違いはないのですが？
なにか私の入力の仕方が違うのかとおもいまして．

（２）
マクロを実行すると土曜日の罫線の右側が消えています．

※全体スケジュールではＹのセルに縦に罫線を引いてるのですが

（スケジュールの太枠の右側の罫線が消えているいる）

個別になると消えてしまいます．

（３）

このWith ～ End With の中では、月曜日の最初のセル群にのみ設定をして

 それぞれのWith の後にある
 　○○.PasteSpecial Paste:=xlPasteFormats
 で、その書式を、他の曜日のセルに貼り付けています。

 この行の前までに（実際には .Copy の前ですが）
 該当部分のフォントの設定をする様にしておけば
 良いのではないかと思います。

との事ですが・・・例えば全て１３ポイント・明朝体に設定するには

具体的にどの様に入力すればよいのですか？

宜しくお願い致します！

くまたろう

 (1)・・・済みません。コードが違う所が有りました。

 (2)・・・こちらではひけているのですが。
 　新しいブックで、以下のコードを試してみてもらえますか。

 '------
Sub test基本書式()
    Dim mC As Long, wC As Long, mR As Long
    wC = 2: mC = 13: mR = 6
    With ActiveSheet
        With .Cells(2, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            .Copy
        End With
            .Cells(3, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(5, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy
        End With
            .Cells(6, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(8, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlDot
                .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlDot
                .Weight = xlThin
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy
        End With
            .Cells(9, 2).Resize(mR, mC - 1).PasteSpecial Paste:=xlPasteFormats
    End With
End Sub
 '------
 C2,M3, C5,M6 , C8,M8:M14　の右側に太い罫線がひかれますか？

 (3)・・・全部同じにすれば良いのなら
        With .Cells.Font
            .Name = "ＭＳ 明朝"
            .Size = 13
        End With
 　を追加します。

 (1)の修正、(3)の追加。と、コードの見直しをしたものを
 ↑元の場所に貼り付けますので、Module2の方のコードを二つとも差し替えて下さい。
 （コードの上に「2011.01.21 コード変更1」と書きました。）

 (HANA)

HANA様

有難うございます．

（１）testのコードをModule2にペーストしたところ

C2,M3, C5,M6 , C8,M8:M14　

の右側全てに太線が引かれました！

（２）そこで次に以下のSub　スケジュール表示～

.Cells(1, 1).Resize(mR).NumberFormatLocal = "h:mm;@"

    End With
End Sub

までをコピーしModule2にペーストしました．

１．標準モジュールを追加して（Module2）以下のコードを貼り付け。

 '===========================
 '　2011.01.21 コード変更1
 '===========================
 '------
Sub スケジュール表示(ByVal AShN As String, ByVal mSh As String, ByVal mBt As String, _
                        ByVal mR As Long, ByVal mC As Long, ByVal wC As Long)
    Dim tbl As Variant, x As Variant, y As Variant, mBt1 As Variant
    Dim dK As Variant
    Dim dic As Object
    Dim i As Long, ii As Long, iii As Long
    Dim xR As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets(AShN)
        tbl = .Cells(1, 1).Resize(mR, mC).Value

        ReDim x(1 To mR, 1 To mC)
        ReDim y(1 To 1, 1 To mC)

            For ii = 1 To mC
                If IsDate(tbl(1, ii)) Then
                    x(1, ii) = tbl(1, ii)
                End If
            Next
        For i = 2 To 3
            For ii = 1 To mC
                    x(i, ii) = tbl(i, ii)
            Next
        Next
                    y(1, 1) = 3
        For i = 4 To mR
            If tbl(i, 1) <> "" And tbl(i, 1) <> "時間" Then
                    y(1, 1) = y(1, 1) + 1
                    xR = y(1, 1)
                    x(xR, 1) = tbl(i, 1)
                For ii = 2 To mC Step 2
                    y(1, ii) = y(1, 1)
                Next
            End If
            For ii = 2 To mC Step wC
                For Each mBt1 In Split(mBt, "/")
                    If CStr(tbl(i, ii)) = mBt1 Then
                        xR = y(1, ii)

                        y(1, 1) = Application.Max(y(1, 1), y(1, ii))
                        y(1, ii) = y(1, ii) + 1

                        For iii = 1 To wC
                            x(xR, ii + iii - 1) = tbl(i, ii + iii - 1)
                            dK = .Cells(i, ii + iii - 1).Font.Bold
                            If dK Then
                                dic("FB") = dic("FB") & "," & .Cells(xR, ii + iii - 1).Address(0, 0)
                            End If
                        Next

                        dK = .Cells(i, ii).Interior.ColorIndex
                        If dK <> xlNone Then
                            dic(dK) = dic(dK) & "," & .Cells(xR, ii).Resize(1, wC).Address(0, 0)
                        End If

                    End If
                Next
            Next
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets(mSh)
        .Cells.Clear

        Call 基本書式(AShN, mSh, mC, wC, y(1, 1))

        For i = 4 To y(1, 1)
            If x(i, 1) <> "" Then
                With .Cells(i, 2).Resize(1, mC - 1)
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                    End With
                End With
            End If
        Next
        For Each dK In dic.Keys
            If dK = "FB" Then
                .Range(Right(dic(dK), Len(dic(dK)) - 1)).Font.Bold = True
            Else
                .Range(Right(dic(dK), Len(dic(dK)) - 1)).Interior.ColorIndex = dK
            End If
        Next
        .Cells(1, 1).Resize(mR, mC) = x
        Application.Goto (.Cells(1, 1))
    Application.ScreenUpdating = True
    End With
Set dic = Nothing
End Sub
 '------
Sub 基本書式(ByVal AShN As String, ByVal mSh As String, ByVal mC As Long, ByVal wC As Long, ByVal mR As Long)
    With Sheets(mSh)
        Sheets(AShN).Rows(1).Copy .Cells(1, 1)
        .Rows(1).Interior.ColorIndex = xlNone

        With .Cells(2, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            .Copy
        End With
            .Cells(2, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(3, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy
        End With
            .Cells(3, 2).Resize(1, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(4, 2).Resize(1, wC)
            With .Borders(xlEdgeTop)
                .LineStyle = xlDot
                .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlDot
                .Weight = xlThin
            End With
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy
        End With
            .Cells(4, 2).Resize(mR - 3, mC - 1).PasteSpecial Paste:=xlPasteFormats

        With .Cells(mR + 1, 2).Resize(1, mC - 1)
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With

        With .Cells.Font
            .Name = "ＭＳ 明朝"
            .Size = 13
        End With

        .Cells(1, 1).Resize(mR).NumberFormatLocal = "h:mm;@"
    End With
End Sub

（３）Module1に以下を貼り付け

Sub 個別2列()

    Const wC As Long = 2
    Const AShN As String = "全体スケジュール"
    Const ShN As String = "1BT_2BT"
    Const BtN As String = "1/2_3"

    Dim ShA As Variant, BtA As Variant
    Dim mR As Long, mC As Long
    Dim i As Long, Li As Long
    With Sheets(AShN)
        With .UsedRange
            mR = .Cells(.Count).Row
        End With
            mC = .Cells(3, Columns.Count).End(xlToLeft).Column
    End With
    ShA = Split(ShN, "_")
    BtA = Split(BtN, "_")
    For Li = 0 To UBound(ShA, 1)
        Call スケジュール表示(AShN, ShA(Li), BtA(Li), mR, mC, wC)
    Next
    Application.Goto (Sheets(AShN).Cells(1, 1))
End Sub

↓↓↓

マクロを実行させその結果・・・

インデックスが有効範囲にありません

のメッセージがでました！

デバックを実行すると（Module1）の

With Sheets(AShN)　←が黄色く表示されます．

すいません．なぜでしょうか？？

 コードは標準モジュールに貼り付けただけで
 部分的に変更　なんてしてませんね？

 「全体スケジュール」のシート名を確認してみてください。

 Module1のコードの初めに
    Const AShN As String = "全体スケジュール"
 ってなってますね。

 黄色くなった行の
  With Sheets(AShN)
              ~~~~ここが　"全体スケジュール"
  With Sheets("全体スケジュール")
 と書いてあるのと同じ事です。

 で、「全体スケジュールシートの」って書いてあるのに
 その名前のシートが無い時に
 その様なメッセージが出ることがあります。

 「全体スケジュール」という名前のシートがあるブックが表示されている状態で
 もう一度マクロを実行してみてください。

 (HANA)

コメント返信：

[ 一覧(最新更新順) ]

[[20110107102718]] 『データーの振り分けとセルの色の反映』（くまたろう） ページの最後に飛ぶ

[[20110107102718]]　『データーの振り分けとセルの色の反映』（くまたろう）　ページの最後に飛ぶ