VBA? と関数。色の付いた文字のセルは？

質問

以前ここで「エクセルで赤の文字のセルとカウントするVBA」を教えていただきました。
その後もう一つ調べたい事がおきました。どなたか力を貸してください。
【例】
月曜日　田中　橋本　佐藤　鈴木　加藤
09：00　田中　　　　　佐藤　　　　　加藤
09：30　田中　　　　　佐藤　鈴木　加藤
10：00　　　　　橋本　佐藤　鈴木　加藤
10：30　　　　　橋本

上記のような契約シフト表を作っています。応援勤務をすると応援した時間分だけ赤色で名前を足しています。以前はこの赤色のみをカウントしその日の合計応援時間を出していました。
しかし又、新たに誰が何時から何時まで応援勤務したかを抽出する必要が出てきました。

(1)　枠の中で赤色の文字になっている氏名の抽出
(2)　その文字の位置から何時から何時までが応援勤務なのかを知りたい

自分で考えましたが何がなにやら頭が混乱してきてしまいました。
どなたかどうか力を貸してください。

ちなみに今までは手で抽出していたのですが雇用者が60名以上にも及ぶ為どうしても簡易計算式で抽出する必要があります。

回答No.5

Wendy02 · ベストアンサー

こんにちは。

私のマクロの場合は、簡単なチェックをしているのですが、

月曜日　田中　橋本　佐藤　鈴木　加藤
09：00　田中　　　　　佐藤　　　　　加藤
09：30　田中　　　　　佐藤　鈴木　加藤
10：00　　　　　橋本　佐藤　鈴木　加藤
10：30　　　　　橋本

最初に、これは、ユーザー設定の部分です。
>　　Const F As String = "A1" 'データの左端上
>　　Const L As String = "A20" 'コピー先

A1 は、月曜日の場所です。
A20は、言うまでもなく、データの出力先です。

次に、

Dif = Val(Range(F).Cells(3, 1).Value) - Val(Range(F).Cells(2, 1).Value)

09：00　←時間のシリアル値
09：30　←時間のシリアル値

A1 の左上端に対して、A3 - A2 を引いた時に、正しい単位が取れていないものは、規格外としています。
「基準以外の表です」という意味は、その差が取れないということです。（オートフィルで作った場合は、厳密には、誤差が生じていることがありますが、大幅には影響はないものと考えています)

「A1」 が、B2 になっても、「A8」になっても、それに対して、自動的に変更されます。

上記の差を取って、それを一単位として計算して、
フォントの色を変えたものを、単位として数えて、差の単位(Dif) を掛けて時間の範囲を出しています。

Format(rng.Cells(m, 1).Offset(, -1).Value + Dif * cnt, "hh:mm")

この中のcnt は単位数として確保されます。ただし、隣り合わせになっているものに対しては、範囲として表示されますが、間が開いていたりする場合は、飛び飛びの表示がされます。

例
田中　10：00-10:30, 11:00-11:30
ということになります。

>上記の出勤表が真ん中（月曜：P25-BM50、火曜：P53-BM78・・・）にあり、左端(A5-K89)には雇用者一覧があり、(P-BM)から情報で出勤曜日が分かるような表も一つのシート内に存在しています。(その他シート右端には曜日・時間帯ごとに人数管理の表もあります。)

私は、シートごとに曜日を変えているなどと想定していましたので、現在のプログラムでは不可能です。私の仕事は、開発が専門ではありませんが、会社のVBAでの開発もいたします。今回のご要望に関しては、正直なところ、それは、無料の掲示板で教えて差し上げるというの範囲を越えています。ご自身で書き換えていただくしかありません。完成までお付き合いさせていただくというにはできないのです。ただし、多少のことは教えることは可能です。

今のマクロを、サブルーチンにしてあげればよいのです。変数になる部分を引数にすれば可能かと思います。

お礼

遅くなりましたが　本当にありがとうございました。
急遽諸事情で　この仕事に向かう事が一時的に出来なくなっていましたが　又、舞戻って来れたのでゆっくり考えたいと思います。
とりあえず　この件は今の断念せざるを得ないと考えました。せっかくお時間いただいたのにすいません。しかし今後の参考にしたいと思います。

回答No.7

hige_082

出力表示を変更してみました
複数ある場合、一行にしました

Sub Macro1()
Dim a As Variant, b As Variant, c As Variant
Dim i As Long, ii As Long
Dim top_Rng As Range, end_Rng As Range
Dim out_Rng As Range

'初期設定----------------------------------------
Set top_Rng = Range("P25") '月曜日の位置
Set out_Rng = Range("A26") '出力先（最初のセル）
'-----------------------------------------------

Set end_Rng = Range("P65536").End(xlUp)
Do Until top_Rng.Row >= end_Rng.Row
For i = top_Rng.Column + 1 To top_Rng.End(xlToRight).Column
a = "": b = "": c = ""
For ii = top_Rng.Row + 1 To top_Rng.End(xlDown).Row
If Cells(ii, i).Font.ColorIndex = 3 Then
If a = "" Then
a = Cells(ii, i).Value & " "
If b = "" Then
b = Format(Cells(ii, top_Rng.Column).Value, "hh:mm") & "-"
Else
b = b & "," & Format(Cells(ii, top_Rng.Column).Value, "hh:mm") & "-"
End If
End If
c = Format(Cells(ii, top_Rng.Column).Value + TimeValue("0:30"), "hh:mm")
ElseIf a <> "" Then
b = b & c
a = ""
End If
Next ii
If b <> "" Then
a = Cells(top_Rng.Row, i).Value & " "
If out_Rng.Value = "" Then
out_Rng.Value = top_Rng.Value
out_Rng.Offset(0, 1).Value = a & b
Else
Cells(Rows.Count, out_Rng.Column).End(xlUp).Offset(1, 0).Value = top_Rng.Value
Cells(Rows.Count, out_Rng.Column).End(xlUp).Offset(0, 1).Value = a & b
End If
End If
Next i
Set top_Rng = top_Rng.End(xlDown)
If Not top_Rng Is end_Rng Then Set top_Rng = top_Rng.End(xlDown)
Loop
End Sub

すいません、＃６コードにエラーがありました
下から８、９行目
　　：
　　：
out_Rng.End(xlDown).Offset(1, 0).Value = top_Rng.Value
out_Rng.End(xlDown).Offset(0, 1).Value = a & b
End If
End If
Next i
Set top_Rng = top_Rng.End(xlDown)
If Not top_Rng Is end_Rng Then Set top_Rng = top_Rng.End(xlDown)
Loop
End Sub
を
Cells(Rows.Count, out_Rng.Column).End(xlUp).Offset(1, 0).Value = top_Rng.Value
Cells(Rows.Count, out_Rng.Column).End(xlUp).Offset(0, 1).Value = a & b
End If
End If
Next i
Set top_Rng = top_Rng.End(xlDown)
If Not top_Rng Is end_Rng Then Set top_Rng = top_Rng.End(xlDown)
Loop
End Sub
へ変更してください

回答No.6

hige_082

ちょいと変更してみました
満足いくかどうか分りませんが

Sub Macro1()
Dim a As Variant, b As Variant
Dim i As Long, ii As Long
Dim top_Rng As Range, end_Rng As Range
Dim out_Rng As Range

'初期設定----------------------------------------
Set top_Rng = Range("P25") '月曜日の位置
Set out_Rng = Range("A91") '出力先（最初のセル）
'-----------------------------------------------

Set end_Rng = Range("P65536").End(xlUp)
Do Until top_Rng.Row >= end_Rng.Row
For i = top_Rng.Column + 1 To top_Rng.End(xlToRight).Column
a = "": b = ""
For ii = top_Rng.Row + 1 To top_Rng.End(xlDown).Row
If Cells(ii, i).Font.ColorIndex = 3 Then
If a = "" Then
a = Cells(ii, i).Value & " " & Format(Cells(ii, top_Rng.Column).Value, "hh:mm") & "-"
End If
b = Format(Cells(ii, top_Rng.Column).Value + TimeValue("0:30"), "hh:mm")
ElseIf a <> "" Then
If out_Rng.Value = "" Then
out_Rng.Value = top_Rng.Value
out_Rng.Offset(0, 1).Value = a & b
Else
Cells(Rows.Count, out_Rng.Column).End(xlUp).Offset(1, 0).Value = top_Rng.Value
Cells(Rows.Count, out_Rng.Column).End(xlUp).Offset(0, 1).Value = a & b
End If
a = ""
End If
Next ii
If a <> "" Then
If out_Rng.Value = "" Then
out_Rng.Value = top_Rng.Value
out_Rng.Offset(0, 1).Value = a & b
Else
out_Rng.End(xlDown).Offset(1, 0).Value = top_Rng.Value
out_Rng.End(xlDown).Offset(0, 1).Value = a & b
End If
End If
Next i
Set top_Rng = top_Rng.End(xlDown)
If Not top_Rng Is end_Rng Then Set top_Rng = top_Rng.End(xlDown)
Loop
End Sub

回答No.4

hige_082

乗りかかった船と言うことで
まあ、Wendy02さんの回答があるので、必要ないと思いますが
一応作ったので

Sub Macro1()
Dim a As Variant, b As Variant
Dim i As Long, ii As Long
For i = 2 To Range("a1").End(xlToRight).Column
a = "": b = "": flg = False
For ii = 2 To Range("a1").End(xlDown).Row
If Cells(ii, i).Font.ColorIndex = 3 Then
If a = "" Then
a = Cells(ii, i).Value & " " & Format(Cells(ii, 1).Value, "hh:mm") & "-"
End If
b = Format(Cells(ii, 1).Value + TimeValue("0:30"), "hh:mm")
ElseIf a <> "" Then
MsgBox a & b & "　これを何処へ書き出すの？"
a = ""
End If
Next ii
If a <> "" Then
MsgBox a & b & "　これを何処へ書き出すの？"
End If
Next i
End Sub

力の差を感じます

お礼

ありがとうございます。
こういうものは本当に感動します。
こちらも簡易の表で試験運用させたら問題なく答えは出てきました。
しかし原版で運用させると答えは出ません。

どうしてでないのかさっぱり分かりません。

回答No.3

Wendy02

こんばんは。

昔、若い時に、派遣の人の仕事から覚えたことですが、どんなにマクロができても、入力を得意とする人には敵わないです。定型業務の場合は、マクロが良いのですが、そうでない場合は、手入力のほうが早いことが多いです。

とりあえず、試してください。コマンドボタンなどに設置すると便利だと思います。

'標準モジュール
'--------------------------------------------------------

Sub ListUpMacro()
　　Dim rng As Range
　　Dim flg As Boolean
　　Dim i As Long, m As Long, n As Long, k As Long
　　Dim r As Variant
　　Dim cnt As Integer
　　Dim Dif As Date
　　Dim buf As String, buf2 As String, tmp As String
　　Const F As String = "A1" 'データの左端上
　　Const L As String = "A20" 'コピー先
　　Const iCLR As Integer = 3 '赤
　　Dim Stock() As Variant

　　Dif = Val(Range(F).Cells(3, 1).Value) - Val(Range(F).Cells(2, 1).Value)
　　If Dif <= 0 Then MsgBox "基準以外の表です", 48: Exit Sub
　　Range(L).CurrentRegion.ClearContents 'コピー先の削除

　　k = -1

　　With Range(F).CurrentRegion
　　　　Set rng = .Offset(1, 1).Resize(, .Columns.Count - 1)
　　End With
　　For Each r In rng.Columns
　　　　For i = 1 To r.Rows.Count
　　　　　　If r.Cells(i, 1).Font.ColorIndex = iCLR And _
　　　　　　　　r.Cells(i, 1).Value <> "" And _
　　　　　　　　flg = False Then
　　　　　　　　m = i: flg = True: cnt = cnt + 1
　　　　　　　　buf = r.Cells(i, 1).Value
　　　　　　ElseIf r.Cells(i, 1).Font.ColorIndex = iCLR And _
　　　　　　　　r.Cells(i, 1).Value <> "" And _
　　　　　　　　flg = True Then
　　　　　　　　n = i: cnt = cnt + 1
　　　　　　ElseIf Trim(r.Cells(i, 1).Value) = "" Then
　　　　　　If flg = True Then n = i
　　　　　　　　flg = False
　　　　　　End If
　　　　　　If n > 0 And flg = False Then
　　　　　　　　buf2 = Format(rng.Cells(m, 1).Offset(, -1).Value, "hh:mm") & " - " & _
　　　　　　　　Format(rng.Cells(m, 1).Offset(, -1).Value + Dif * cnt, "hh:mm")
　　　　　　　　If tmp <> buf Then
　　　　　　　　　　k = k + 1
　　　　　　　　　　ReDim Preserve Stock(1, k)
　　　　　　　　　　Stock(0, k) = buf
　　　　　　　　　　tmp = buf
　　　　　　　　　　Stock(1, k) = buf2
　　　　　　　　Else
　　　　　　　　　　Stock(1, k) = Stock(1, k) & ", " & buf2
　　　　　　　　End If
　　　　　　　　flg = False: m = 0: n = 0: cnt = 0
　　　　　　End If
　　　　Next i
　　　　buf = "": buf2 = "": tmp = ""
　　Next
　　If k > -1 Then
　　　　Range(L).Value = Range(F).Value
　　　　Range(L).Offset(1).Resize(UBound(Stock(), 2) + 1, 2).Value = _
　　　　Application.Transpose(Stock())
　　End If
　　Set rng = Nothing
End Sub

お礼

ありがとうございます。
勉強不足で時間がかかっています。
どうしても「基準以外の表です」のメッセージのみしか出ません。

勉強不足をあきれられる事承知でお伺いしたいのですが
上記のマクロは
どのような事をしてるマクロでしょうか？
本当に申し訳ございません

補足

簡易の表で作成し試した所感動して叫んでしまいました！
そうです。このようにしたいのですが
実物で動かすと動きません。
理由がどうしても分かりません。
実物の「出勤管理表」には色々なものが1つのシートの中にあります。
上記の出勤表が真ん中（月曜：P25-BM50、火曜：P53-BM78・・・）にあり、左端(A5-K89)には雇用者一覧があり、(P-BM)から情報で出勤曜日が分かるような表も一つのシート内に存在しています。(その他シート右端には曜日・時間帯ごとに人数管理の表もあります。)

上記のような複雑な環境の為に、
このマクロをうまく起動させることが出来ないのでしょうか？
それともどこか手を加えれば同じように動かす事は出来ますでしょうか？

回答No.2

Wendy02

こんにちは。

>以前ここで「エクセルで赤の文字のセルとカウントするVBA
http://oshiete1.goo.ne.jp/qa4508114.html

どちらかというと、前の話は引きずらないほうがよいかなって思います。もちろん、条件付き書式と、書式の文字の色との混在で数える話なんていうのは、VBAの一般的な範疇を越えていると思います。

今回の質問内容は、どちらかというと、アイデア倒れのような気がします。VBAプログラマが、逆に、そのような設計を考えるかというと、おそらく、"NO" です。そういうことは考えません。

ところで、質問の内容が良く理解していないのですが、
田中さんは、9:00 - 9:30
橋本さんは、10:00 - 10:30
佐藤さんは、9:00 - 9:30, 10:00 -

というように出すのですか？

質問する場合は、最初の部分と求める結果があって、その間をどう埋めようとするかが問題であっても、それがないと、回答し続けるのは困難だと思います。

補足

>どちらかというと、アイデア倒れのような気がします
アイデア倒れかも知れないと思ってきました。

＞ところで、質問の内容が良く理解していないのですが、
　田中さんは、9:00 - 9:30
　橋本さんは、10:00 - 10:30
　佐藤さんは、9:00 - 9:30, 10:00 -

非常に質問の仕方が悪いことを反省しました。申し訳ありません。
現在上記の様になっているものがシフト表としてあります。このシフト表は応援勤務者があれば赤色で加筆されます。

月曜日　田中　橋本　佐藤　鈴木　加藤
09：00　田中　　　　　佐藤　　　　　加藤
09：30　田中　　　　　佐藤　鈴木　加藤
10：00　　　　　橋本　佐藤　鈴木　加藤
10：30　　　　　橋本
↓
田中さんが10時から11時まで1時間残業勤務(応援勤務)してくれれば
以下の表になります。(このとき10：00と10：30の田中は赤色です)
月曜日　田中　橋本　佐藤　鈴木　加藤
09：00　田中　　　　　佐藤　　　　　加藤
09：30　田中　　　　　佐藤　鈴木　加藤
10：00　田中　　橋本　佐藤　鈴木　加藤
10：30　田中　　橋本　佐藤

欲しい答え）
月曜日　
田中　10：00-11：00
佐藤　10：30-11：00

と別の所に羅列式で出るようにしたいのです。
どうにか力を貸してください。宜しくお願い致します

回答No.1

hige_082

詳細が無いので、この程度の回答しか出来ません
Sub test()
Dim a As Range
For Each a In Cells
If a.Font.ColorIndex = 3 Then
MsgBox a.Value
End If
Next a
End Sub
参考まで

お礼

遅くなりましたが　本当にありがとうございました。
急遽諸事情で　この仕事に向かう事が一時的に出来なくなっていましたが　又、舞戻って来れたのでゆっくり考えたいと思います。
お二方とも沢山時間を要していただいたのにお返事できなくなり申し訳ありません。
又、頑張って解釈できる様にします。

補足

涙・・すいません。
考えてみましたがやはり知識不足で分かりません。
上記のVBAを設定したあとどこで(どんな式で？)抽出させれるのでしょうか？

＞詳細が無いので、この程度の回答しか出来ません
いかに出来るだけ詳しく詳細を書いてみました。お力を貸してください。