[[20130518163959]]　『VBAによる固定曜日のスケジュール入力』（ココロ）　ページの最後に飛ぶ

『VBAによる固定曜日のスケジュール入力』（ココロ）

お世話になります。

Ｄ１に「2013年6月」と入力しており、下記のような表が１か月分あります。

	A列	B列	C列	D列
4行目	日付	曜日	祝日	予定
5行目	1	土		
6行目	2	日		
7行目	3	月		フィードバック提出
8行目	4	火		
9行目	5	水		講習会
10行目	6	木		
11行目	7	金		
12行目	8	土		
13行目	9	日		
14行目	10	月		
15行目	11	火		
16行目	12	水		会議
17行目	13	木		シフト提出
18行目	14	金		
省略				
34行目	30	日		
35行目	31	月

固定日にて入力する予定や固定曜日によって入力する予定などがあり
ＶＢＡにて毎月作成時に自動入力するマクロを組んでいます。
固定日の入力まではできたのですが
固定曜日による入力に戸惑っており、皆様のお力添えをお願い致します。

例：第１水曜日なら「14：00　講習会」、第２水曜日なら「12：00　会議」　など

なお、日付欄は数字入力（1、2・・・）となっており、日付形式（2013/6/1）にはなっていません。

宜しくお願い致します。

[エクセルのバージョン]
EXCEL2007で作成、保存はxls形式
PCによってはEXCEL2010やEXCEL2003での使用もある

[OSのバージョン]
Windows Vistaを使用
PCによってはWIN7やWINXPもある

 たとえば

http://tatehide-blog.net/archives/excelvba_getdateweeknum.html

 ここに、第○　□曜日　を求める　getDateWeekNum　が紹介されている。
 このようなコードを使い、日付を求めれば、もう、アップされたレイアウトでは
 簡単に、その場所がわかるよね。

 (ぶらっと)

 マクロを作る勉強としてなら、[D1] に、2013/6/1 と日付データが入力されているとの前提として・・・。
 問題は、具体的な予定をどのように指定するかですね。

 Sub Test()
   Dim i&, n&, D As Date
      D = Range("D1").Value
      For i = 5 To 35　'5 ～35行
         If Weekday(D) = 4 Then　'水曜
            n = n + 1
            Select Case n
               Case Is = 1　'第一
                  Cells(i, "d").Value = "14:00 講習会"
               Case Is = 2　'第二
                  Cells(i, "d").Value = "12:00 会議"
            End Select
         End If
         D = D + 1
      Next
 End Sub
 (暇人)

ぶらっと様

上記確認させていただきました。
B列が日付形式だったら反映できたのですが、数字の場合ができませんでした。
現状のコードは、

Dim g As Integer
Dim r As Integer
'固定日

    For g = 5 To 35
        If Cells(g, 1) = 3 Then
            '毎月3日
            Cells(g, 4) = "フィードバック提出"
        ElseIf Cells(g, 1) = 13 Then
            '毎月13日
            Cells(g, 4) = "シフト提出"
        Else
        End If
    Next g
'固定曜日
    For r = 5 To 35
        '第一水曜日：パソコン講習
        If Cells(r, 1) = getDateWeekNum(Range("D2"), Range("E2"), vbWednesday, 1) Then
                Cells(r, 4) = "14：00　パソコン講習会"
        '第二水曜日：会議
        ElseIf Cells(r, 1) = getDateWeekNum(Range("D2"), Range("E2"), vbWednesday, 2) Then
                Cells(r, 4) = "12：00　会議"
        Else
        End If
    Next r
※D2には「=YEAR(D1)」、E2には「=MONTH(D1)」が白文字にて入力しています。※

になるのですが、固定日は数字、固定曜日は日付形式となってしまうため、どっちかが反映できない状態になってしまいました。
日付を日付形式にして統一させようともしたのですが、その場合のコードがわかりませんでした。

質問が変わってしまうかもしれませんが、その場合はどうしたらよいでしょうか。

（ココロ）

暇人様

ありがとうございます。上記コードを動かすことできました。
追加で質問なんですが、E列F列にも同じ情報を入力させたい場合の方法は有りますでしょうか。

（ココロ）

 おもしろそうなので、私なら案です。
 (Mook)

 Sub Sample()
    Dim ym
    ym = InputBox("作成する月をYYYYMMの形式で入れてください。", "作成月指定", Application.Text(Date, "YYYYMM"))
    If Len(ym) <> 6 Or IsDate(CDate(Left(ym, 4) & "/" & Right(ym, 2) & "/01")) = False Then
        MsgBox "指定月が正しくありません"
        Exit Sub
    End If

    Dim ws As Worksheet
    Set ws = Worksheets.Add(before:=Worksheets(1))

    Dim st As Date
    st = CDate(Left(ym, 4) & "/" & Right(ym, 2) & "/01")

    Dim scDic
    Set scDic = createScheduleDic()

    ws.Range("A4:D4") = Array("日付", "曜日", "祝日", "予定")
    Dim r As Long
    r = 5

    Dim dt As Date
    dt = st
    ws.Range("D1") = Application.Text(dt, "YYYY年M月")

    Dim nthDow
    Do While Month(dt) = Month(st)
        nthDow = CStr(Int((Day(dt) - 1) / 7) + 1) & Application.Text(dt, "aaa")
        ws.Cells(r, "A") = dt
        ws.Cells(r, "B") = dt

        If scDic.exists(CStr(Day(dt))) = True Then ws.Cells(r, "D").Value = scDic(CStr(Day(dt)))
        If scDic.exists(nthDow) = True Then
            If Len(ws.Cells(r, "D").Value) > 0 Then ws.Cells(r, "D").Value = ws.Cells(r, "D").Value & vbLf
            ws.Cells(r, "D").Value = ws.Cells(r, "D").Value & scDic(nthDow)
        Else
            If scDic.exists(nthDow) = True Then ws.Cells(r, "D") = scDic(nthDow)
        End If

        Select Case Weekday(dt)
            Case vbSunday
                Cells(r, "A").Resize(1, 4).Interior.ColorIndex = 38
            Case vbSaturday
                Cells(r, "A").Resize(1, 4).Interior.ColorIndex = 34
        End Select

        r = r + 1
        dt = DateAdd("d", 1, dt)
    Loop

    ws.Range("A4").Resize(r - 3, 4).Borders.LineStyle = xlContinuous

    ws.Columns("A").NumberFormatLocal = "d"
    ws.Columns("B").NumberFormatLocal = "aaa"
    ws.Columns("A:D").AutoFit
 End Sub

 Function createScheduleDic()
    Set createScheduleDic = CreateObject("Scripting.Dictionary")
    setSchedule createScheduleDic, 3, "フィードバック提出"
    setSchedule createScheduleDic, 13, "シフト提出"
    setSchedule createScheduleDic, "1水", "14:00 講習会"
    setSchedule createScheduleDic, "2水", "12:00 会議"
 End Function

 Function setSchedule(scDic, dt, sc)
    dt = CStr(dt)
    If scDic.exists(dt) = False Then
        scDic(dt) = sc
    Else
        scDic(dt) = scDic(dt) & vbLf & sc
    End If
 End Function

 >B列が日付形式だったら反映できたのですが、数字の場合ができませんでした

 紹介したプロシジャは、日付を取得するよね。
 で、取得した日付から Day(その日付) で　日　が取得できるね。
 それが、たとえば１０だったとすると、提示のレイアウトでは　１日　が　５行目なので
 １４行目、つまり取得した日 + 4 行目　が求める行番号なんだけど？

 (ぶらっと)

 前掲の Test の単なる応用だけだと思いますが・・・・。
 Sub TestB()
   Dim i&, n&, D As Date
      D = Range("D1").Value '2013/6/1
      For i = 5 To 35
         '日固定
         If Cells(i, 1).Value = 3 Then Cells(i, "d").Resize(, 3).Value = "フィードバック提出"
         If Cells(i, 1).Value = 13 Then Cells(i, "d").Resize(, 3).Value = "シフト提出"
         '曜日固定
         If Weekday(D) = 4 Then
            n = n + 1
            Select Case n
               Case Is = 1 '一週
                  Cells(i, "d").Resize(, 3).Value = "14:00 講習会"
               Case Is = 2 '二週
                  Cells(i, "d").Resize(, 3).Value = "12:00 会議"
            End Select
         End If
         D = D + 1
      Next
 End Sub
 (暇人)

Mook様
ありがとうございます。

ぶらっと様
getDateWeekNum(Range("D2"), Range("E2"), vbWednesday, 1)をDay()で括ったら反映できました！単純ではありますが、そこまで頭が回りませんでした。ヒントをありがとうございます。

暇人様
Resizeの存在が頭にありませんでした。ありがとうございます。

皆様の内容を更に工夫して使用しやすいものを作りたいと思います。
ありがとうございました！

（ココロ）

コメント返信：

[ 一覧(最新更新順) ]

[[20130518163959]] 『VBAによる固定曜日のスケジュール入力』（ココロ） ページの最後に飛ぶ

[[20130518163959]]　『VBAによる固定曜日のスケジュール入力』（ココロ）　ページの最後に飛ぶ