| |
実行タイミング、日付の範囲、シートの範囲等が解らないので
ActiveSheetのC2の日付から、其の月の月末までの日付までを
ActiveSheet以降のシートのC2に、もしシートが無いならシートを追加して
代入して行くサンプルを示します
Option Explicit
Public Sub Sample()
'各シートの書き込み位置
Const cstrPos As String = "C2"
Dim i As Long
Dim lngSheetNumb As Long
Dim vntTop As Variant
Dim dtmEnd As Date
'ActiveSheetに就いて
With ActiveSheet
'C2の値を変数に取得
vntTop = .Range(cstrPos).Value
'変数の値が日付と認められ無いなら
If Not IsDate(vntTop) Then
'変数の値が文字列なら
If VarType(vntTop) = vbString Then
'半角に出きる全角を半角に変換
vntTop = StrConv(vntTop, vbNarrow)
'変数の中の"("を捜す
i = InStr(1, vntTop, "(", vbTextCompare)
'"("が有る場合
If i <> 0 Then
'"("拠り前の文字を取得
vntTop = Left(vntTop, i - 1)
'変数の値が日付と認められるなら
If IsDate(vntTop) Then
'変数の値をシリアル値とする
vntTop = CDate(vntTop)
Else
'C2の値が日付では無いとする
i = 0
End If
End If
End If
Else
'C2の値が日付で有るとする
i = 1
End If
'C2の値が日付では無いならSubを抜ける
If i = 0 Then
Exit Sub
End If
'月末の日付を変数に格納する
dtmEnd = DateSerial(Year(vntTop), Month(vntTop) + 1, 0)
'ActiveSheetのSheet番号を取得
For i = 1 To Worksheets.Count
If .Name = Worksheets(i).Name Then
lngSheetNumb = i
Exit For
End If
Next i
End With
'Worksheetsコレクションに就いて
With Worksheets
'先頭日付〜最終日付まで繰り返し
For i = vntTop To dtmEnd
'Sheet番号がコレクションの最大値を超えるなら
If .Count < lngSheetNumb Then
'コレクションにシートを追加
.Add After:=.Item(.Count)
End If
'Sheet番号のC2に就いて
With .Item(lngSheetNumb).Range(cstrPos)
'書式を設定
.NumberFormatLocal = "ggge""年""m""月""d""日(""aaa"")"""
'日付をC2に代入
.Value = i
End With
'Sheet番号を更新
lngSheetNumb = lngSheetNumb + 1
Next i
End With
Beep
MsgBox "処理が終了しました"
End Sub
|
|
Hirofumi
- 04/5/5(水) 10:22 -
