Excel-VBA 月次更新

シフト管理を行うExcelVBAのSource。
ここでのシフトの基本は、一週間の予定を事前に決定し、それを5週分連動され、
一ヶ月の予定は、この中なら切り出す仕組みとしている。

具体的には、日から始まり土で終わる週予定の作成し、その5週分をセルのリンクで
構築する。

一ヶ月で１Bookを使う、ブック名の末尾には年と月を表す数字がある
Furesia-202211.xlsm
最後の6文字で年と月を表している、月次更新は、当月BookをRenameして保存する。

週分の予定を確定させ、このVBAを動かすと、Book名から該当月を切り出し、月初
の日付（当然01）を付加し、この日付の曜日を関数で求め、日曜日を1とする値を
得る。更に、月末の日付を求める（28，29，30，31）、この2つの値があれば、
5週分のデータから該当月の一ヶ月分を切り出し、作業Sheetに貼り付けることを
行うアルゴリズムとなっている、手作業なら簡単であるが、日付や曜日の錯誤の
恐れがあるので、あえてVBAで処理をした。

Sub Month_UDT()
'
' Month_UDT Macro
' MAS1の5週間連続データから、月の状況に合わせた期間をコピーし、SKD1に貼り付ける

'
Dim XlName As String

Dim Mou As String
Dim MouED As String

Dim BookNam As String
Dim MonST_n As Long
Dim MonEN_n As Long
Dim SST_n As Long
Dim SEN_n As Long

Dim Rtn As Long

' 　ファイル名を取得
XlName = ThisWorkbook.Name

' Debug.Print ThisWorkbook.Name

BookNam = Mid(XlName, 9, 6) ' ファイル名から年・月を切り出す

Sheets("MAS1").Select

Mou = Left(BookNam, 4) & "/" & Right(BookNam, 2) & "/01" ' 検索用に年月日を作成
'Debug.Print Mou

MouED = WorksheetFunction.EoMonth(Mou, 0) ' 月末日の決定

Range("A5") = Mou
Range("A6") = WorksheetFunction.EoMonth(Range("A5").Value, 0)

MonST_n = Weekday(Mou) ' 1日の曜日を求める

SST_n = MonST_n + 18

'MonEN_n = WorksheetFunction.EoMonth(Range("A5").Value, 0)

MonED = WorksheetFunction.EoMonth(Range("A5").Value, 0)

MonED_n = Day(MonED) + SST_n - 1

Range(Cells(13, SST_n), Cells(62, MonED_n)).Select ' 当月分のコピー

' Selection.Copy

Rtn = MsgBox("コピーしますか、月初の曜日を確認して下さい", vbYesNo)

If Rtn = vbYes Then

Sheets("SKD1").Select 'SKD1の古いデータの削除

Range("AD2:AG2").Select
Selection.ClearContents

Range("C10:AG59").Select
Selection.ClearContents

Sheets("MAS1").Select

Range(Cells(13, SST_n), Cells(62, MonED_n)).Select ' 当月分のコピー

Selection.Copy

Sheets("SKD1").Select ' 貼り付け
Range("C10").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select

Sheets("MAS1").Select ' 曜日のコピー

Range(Cells(12, SST_n), Cells(12, MonED_n)).Select

Application.CutCopyMode = False
Selection.Copy

Sheets("SKD1").Select ' 貼り付け
Range("C2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Else

End If

'

End Sub

わかお　かずまさ

VegaSystems