[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『祝日以外の休日を除いて勤務日数を算出するには？』（たろう）
先日から以下のようなボックス型のカレンダー作成について、ご教授頂いております。
みなさん、ありがとうございます。
さらに質問させて頂きます。
一年間の勤務日数を算出する場合に、土日以外に年末年始(12月29日〜1月3日)を除いた
日数の算出をさせたいのです。
例えば元旦が日曜日の場合、2日月曜日が振替休日になりますが、これは祝日一覧に加えて、条件付き書式NETWORKDAYSで算出できることは理解していますが、これをうまく勤務日数として算出する方法をご教授願います。よろしくお願いします。
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
それから、、、ある一定の期間の中で、祝日、土曜日、日曜日、年末、年始それぞれの日数も求められたら
と思います。土曜日、日曜日、年末、年始が祝日に重なった場合は、祝日としてカウントしたいです。
みなさんのお知恵をどうかお願いします！！
（たろう） 2015/11/21(土) 01:45
＞例えば元旦が日曜日の場合、2日月曜日が振替休日になりますが、 ＞これは祝日一覧に加えて、条件付き書式NETWORKDAYSで算出できることは理解していますが、 ＞これをうまく勤務日数として算出する方法
１．NETWORKDAYS() は勤務日数を算出する関数そのものだと思うのですけど、 実際に使ってみて旨く行かなかったのですか？ そうだとしてら、どんな数式だったのかここに掲示して貰えませんか？ (ついでに、正解日数が何日なのかもお願いします）
＞ある一定の期間の中で、祝日、土曜日、日曜日、年末、年始それぞれの日数も求められたら ＞と思います。土曜日、日曜日、年末、年始が祝日に重なった場合は、祝日としてカウントしたいです。
２．意図するところを正確に確認したいので、 今年の12月1日から来年の1月31日の2ヶ月間がある一定期間と仮定した場合、 それぞれどうなればいいのか、正解日数を書いてください。
＞年末年始(12月29日〜1月3日)
３．細かい話ですが、対象が一年間とすると、年末年始とはよく言うのの、 今回は、年始年末(1月1日から1月3日、12月29日〜12月31日)ですよね。
それとも年末をまたぐ１年間を対象にすることもあるんですか？
（半平太） 2015/11/21(土) 07:19
なんで [[20151119123540]] で続けないの？しかも笑さんの質問に答えてないし。 （bi） 2015/11/21(土) 07:37
1.=NETWORKDAYS(B49,B50,祝日)です。
2.12月29日〜31日が年末休暇、1月1日は祝日、1月2日〜3日は年始休暇としたいです。
この二カ月間の勤務日数は、上記に加え、土日祝日になり、38日の勤務日数を自動計算から
抽出したいです。
3.いいえ、期間は年度ですので、H27.4.1〜H28.3.31です。
よろしくお願いします。
（たろう） 2015/11/21(土) 11:02
（たろう） 2015/11/21(土) 11:07
１．エクセルのバージョンですけど、前回はXL2013、今回はXL2007となっています。 XL2013の方が使える関数が多いのでより有用なんですけど、今回は本当にXL2007なんですか？
＞1.=NETWORKDAYS(B49,B50,祝日)です。 ２．それで正しいと思いますが、意図した結果が出なかったのですか？
＞それから、、、ある一定の期間の中で、祝日、土曜日、日曜日、年末、年始それぞれの日数も求められたら ＞と思います。土曜日、日曜日、年末、年始が祝日に重なった場合は、祝日としてカウントしたいです。 ３．私としては、2015/12/1〜2016/1/31の2ヶ月間と仮りに決め、求めるべき各項目別の正解日数を 書いていただきたいのです。(推測でやると2度手間になることが多い為）
＞私の作製途中のデータを見て頂くことは可能でしょうか？ ４．ファイルをどこかに置かれたり、送られたりするのは好みませんので、 以下の手順で、そちらのレイアウトとデータを再現させるマクロを書いて、 この掲示板に貼り付けてください。
<手順> (1) 対象となるシートの「シート見出し」を右クリックして、コードの選択を選ぶ。 すると、画面中央に白いエリアが出ます。VBE画面と呼ばれています。 そこに後記マクロコードを貼り付けてください。
(2) Altキーを押しながらF11キーを推すと、エクセルの画面に戻りますので、 本問に関連するセル範囲をドラッグ選択してください。
(3) 範囲が選択された状態で、再度、Altキーを押しながらF11キーを押してVBE画面に戻り、F5を押す。 つまり、「レイアウトとサンプルデータ再現マクロ作成」と云うマクロを実行することになります。
するとマクロが実行され、「出力Wsh」と云うシートが挿入され、所要マクロコードが書きこまれます。 それと同時に、自動的にクリップボードにも作成後のマクロコードが記憶されます。
なので、マクロを実行した後、直ぐこの掲示板等に行って、右クリック→貼付け を行えば 自動作成されたマクロコードが掲示板にアップできます。 なお、「出力Wsh」は以後不要なので、削除してください。 また、貼り付けたマクロも不要になるので、これはクリアしてください。
’シートに貼り付けるべきマクロコード(ここから) −−−−−−−−−−−−−−−
Public Sub レイアウトとサンプルデータ再現マクロ作成()
Const modelMRG As String = " Range(""Adrs"").Merge"
Const modelCLR As String = " Range(""Adrs"").Interior.ColorIndex = "
Const modelVAL2 As String = " Range(""Adrs"").Value = "
Const modelFML As String = " Range(""Adrs"").FormulaR1C1Local = "
Const modelFMT As String = " Range(""Adrs"").NumberFormatLocal = ""@""" '文字列(頭が「’」のデータ処理
Const modelFME As String = " Range(""Adrs"").NumberFormatLocal = " '標準外の表示形式
Dim WSF As WorksheetFunction
Dim rslt
Dim dataToFil
Dim cel As Range
Dim Codes As String
Dim NN As Long, PP As Long
Dim BlocksToRight As Long, BlocksToBottom
Dim rngSelected As Range
Set rngSelected = Intersect(Selection, Selection.Parent.UsedRange)
If rngSelected.Rows.Count > 200 Or _
rngSelected.Columns.Count > 78 Then
If vbNo = MsgBox("対象範囲(" & rngSelected.Address(0, 0) & _
"）が広過ぎの感がありますが、範囲は正しいですか？", vbYesNo) Then
Exit Sub
End If
End If
Set WSF = WorksheetFunction
On Error Resume Next
ThisWorkbook.Sheets("出力Wsh").Range("A1").Value = Empty 'シート存在テスト
If Err.Number <> 0 Then
ThisWorkbook.Sheets.Add.Name = "出力Wsh"
End If
On Error GoTo 0
NN = 0
With ThisWorkbook.Sheets("出力Wsh")
NN = NN + 1: .Cells(NN, 1).Value = "Private Sub onlyOnce()"
NN = NN + 1: .Cells(NN, 1).Value = "Rem ' Range(""" & rngSelected.Address(, , , True) & """).Clear"
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 結合状態を処理"
For Each cel In rngSelected '結合状態を処理----------------
With cel
If .MergeCells Then '結合状態になっているセルを処理
If .MergeArea.Item(1).Address = .Address Then
NN = NN + 1
dataToFil = Replace(modelMRG, "Adrs", .MergeArea.Cells.Address(0, 0))
ThisWorkbook.Sheets("出力Wsh").Cells(NN, 1).Value = dataToFil
End If
End If
End With
Next
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 数式セル以外をまとめて処理"
rslt = sameKindS(rngSelected, modelVAL2, "値")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
' NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
rslt(PP) = Replace(rslt(PP), vbLf, """ & Chr(10) & """)
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 数式セルをまとめて処理"
rslt = sameKindS(rngSelected, modelFML, "数式")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 標準外書式セルをまとめて処理"
rslt = sameKindS(rngSelected, modelFME, "セル書式")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = Empty
NN = NN + 1: .Cells(NN, 1).Value = " Rem 塗りつぶしセルをまとめて処理"
rslt = sameKindS(rngSelected, modelCLR, "塗りつぶし")
For PP = LBound(rslt) To UBound(rslt)
If rslt(PP) <> Empty Then
NN = NN + 1: .Cells(NN, 1).Value = rslt(PP)
End If
Next PP
NN = NN + 1: .Cells(NN, 1).Value = "End Sub"
.Range("A1").Resize(NN, 1).Copy
End With
End Sub
Private Function sameKindS(rng As Range, modelFMS, Optional aim As String = "値") '一般形
Dim dic As Object
Dim cel As Range
Dim Adrs As String
Dim AdrsBreak
Dim sNum As String
Dim eachKey
Dim NN As Long
Dim dataToFil
Dim ItemVal
Set dic = CreateObject("Scripting.Dictionary") ' 連想配列の定義
For Each cel In rng
ItemVal = Empty
Select Case aim
Case "値"
If Not cel.HasFormula And Not IsEmpty(cel.Value) Then
ItemVal = IIf(IsError(cel.Value2), cel.Formula, cel.Value2)
End If
Case "数式"
If cel.HasFormula Then
ItemVal = cel.FormulaR1C1Local
End If
Case "セル書式"
If cel.NumberFormatLocal <> "G/標準" And _
TypeName(cel.Value) <> "Currency" Then '標準外の書式を反映させる。通貨型は面倒なので処理外
ItemVal = cel.NumberFormatLocal
End If
Case "塗りつぶし"
If cel.Interior.ColorIndex <> -4142 Then '塗りつぶしがあるセルを処理
ItemVal = cel.Interior.ColorIndex
End If
End Select
If Not IsEmpty(ItemVal) Then
If dic.Exists(ItemVal) Then
AdrsBreak = Split(dic(ItemVal), "#")
sNum = AdrsBreak(0) + 1
dic(ItemVal) = sNum & "#" & AdrsBreak(1) & cel.Address(0, 0) & " "
Else
dic.Add ItemVal, "1#" & cel.Address(0, 0) & " "
End If
End If
Next
Dim rslt()
Dim brd
ReDim rslt(0 To Application.Max(0, dic.Count - 1))
NN = 0
For Each eachKey In dic
AdrsBreak = Split(dic(eachKey), "#")
Adrs = Replace(RTrim(AdrsBreak(1)), " ", ",")
Adrs = AddressUnited(Adrs) 'バラバラのAddressを統合
For Each brd In Split(Adrs, "#!#")
If brd <> "" Then
dataToFil = IIf(Application.IsText(eachKey), """", "") & Replace(eachKey, """", """""") & _
IIf(Application.IsText(eachKey), """", "")
dataToFil = Replace(modelFMS, "Adrs", brd) & dataToFil
NN = NN + 1
If NN - 1 > UBound(rslt) Then
ReDim Preserve rslt(0 To NN - 1)
End If
rslt(NN - 1) = dataToFil
End If
Next
Next
sameKindS = rslt
End Function
Private Function AddressUnited(adr) 'バラバラのAddressを統合
Dim scopeRange As Range
Dim adrRemain As String
Dim adrForRowProc As String
Dim adrForColProc As String
Set scopeRange = Range(Split(adr, ",")(0))
adrRemain = "," & adr & ","
Do While Not scopeRange Is Nothing
uniteRowDir scopeRange, adrRemain
adrForRowProc = adrForRowProc & scopeRange.Address(0, 0) & ","
If Len(adrRemain) < 4 Then
Set scopeRange = Nothing
Else
Set scopeRange = Range(Split(adrRemain, ",")(1))
End If
Loop
Set scopeRange = Range(Split(adrForRowProc & ",", ",")(0))
adrRemain = "," & adrForRowProc
Do While Not scopeRange Is Nothing
uniteColDir scopeRange, adrRemain
adrForColProc = adrForColProc & scopeRange.Address(0, 0) & ","
If Len(adrRemain) < 4 Then
Set scopeRange = Nothing
Else
Set scopeRange = Range(Split(adrRemain, ",")(1))
End If
Loop
AddressUnited = get小分け(adrForColProc) '10セル以上は長いので同じ構文でも分割作成
End Function
Function get小分け(adrForColProc)
Dim strSRC
Dim brDown, Cntr, sss, QQ, adrsUnit, numOfadrs
brDown = Split(adrForColProc, ",")
numOfadrs = UBound(brDown) '対象個数
adrsUnit = Int((numOfadrs - 1) / 10) + 1
adrsUnit = Application.RoundUp(UBound(brDown) / adrsUnit, 0) 'まとめるアドレスの数
For Cntr = 0 To numOfadrs - 1 Step adrsUnit
sss = stEd(Cntr, Application.Min(numOfadrs - 1, Cntr + adrsUnit - 1), brDown)
strSRC = IIf(strSRC = "", sss, strSRC & "#!#" & sss)
Next Cntr
get小分け = strSRC & "#!#"
End Function
Function stEd(st, ed, ary)
Dim NN, str
str = ary(st)
For NN = st + 1 To ed
str = str & "," & ary(NN)
Next NN
stEd = str
End Function
Private Sub uniteRowDir(ByRef scopeRange, ByRef adrRemain)
Dim brdAry
brdAry = Split(adrRemain, ",")
adrRemain = Replace(adrRemain, "," & brdAry(1) & ",", ",") 'アドレス文字列から除外
If Range(brdAry(1)).Cells(1, 2).Address(0, 0) = brdAry(2) Then '右横に同じものあり
Set scopeRange = Range(scopeRange, Range(brdAry(2)))
uniteRowDir scopeRange, adrRemain
End If
End Sub
Private Sub uniteColDir(ByRef scopeRange, ByRef adrRemain) '直下が同じ範囲かチェック
Dim brdAry
Dim adrsUnder As String
brdAry = Split(adrRemain, ",")
adrRemain = Replace(adrRemain, "," & scopeRange.Rows(scopeRange.Rows.Count).Address(0, 0) & ",", ",") 'アドレス文字列から除外
adrsUnder = scopeRange.Rows(scopeRange.Rows.Count + 1).Address(0, 0) '結合セル対策
If adrRemain Like "*," & adrsUnder & ",*" Then '真下に同じものあり
Set scopeRange = Range(scopeRange, Range(adrsUnder))
uniteColDir scopeRange, adrRemain
End If
End Sub
’貼付コード ここまで −−−−−−−−−−−−−−−−−−−−−−
（半平太） 2015/11/21(土) 15:48
当方の2度にわたる質問にお答え頂いていないですし、 やる気も感じられませんので、私はおります。
他の回答者のレスをお待ちください。
（半平太） 2015/11/21(土) 17:01
> 直接データを見て頂ければ有難いのですが。
期間内日数を条件付きで算出するんだったら、その条件を言葉で説明すれば済む話では？ 開始日・終了日・祝日リスト以外のデータって何？
> =NETWORKDAYS(B49,B50,祝日) > 38日の勤務日数を自動計算から抽出したいです。
B49: 2015/12/1 B50: 2016/1/31 祝日リストに「2015/12/23、2015/12/29〜2016/1/3、2016/1/11」を入力して 「38」になったけど、そちらではどうなったの？
> 例えば元旦が日曜日の場合、2日月曜日が振替休日になりますが > これをうまく勤務日数として算出する方法
どういうこと？ 1/2 が振替休日だったら除外せずに日数に入れたいってこと？
> 期間は年度ですので、H27.4.1〜H28.3.31です。
年が変わるだけで、期間は4/1〜翌年3/31だけ？ だったら年末は数えるまでもなく「3」では？ 年末年始に土日が含まれていたら、どうなればいいの？ 1/2が振替休日だったらどうなればいいの？
↑ 年末年始の日数の件です。（17:30補足）
> エクセルのバージョンは職場が2013、自宅が2007です。
どっちに合わせればいいの？ （笑） 2015/11/22(日) 13:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.