[[20150224195048]]　『月を加算したシートネームから値を書き込みたい』（nobu）　ページの最後に飛ぶ

『月を加算したシートネームから値を書き込みたい』（nobu）

以下にて最終？？？部分で良いと思うのですが(自信ないですが)
新しく作成した１ヶ月足したシートネームから取得しＢ４に取得した月の
最終日を書き込みたいのですが、ご指導お願いします。
よろしくお願いします。

Sub １ヶ月加算()

    Dim sh_name As String
    Dim d As Date
    Dim ws As Worksheet
    Dim n As Long

    With ActiveSheet

        If Len(.Name) = 6 And IsDate(Left(.Name, 4) & "/" & Right(.Name, 2) & "/1") Then
            ' その日付を取得
            d = CDate(Left(.Name, 4) & "/" & Right(.Name, 2) & "/1")

            sh_name = Format(DateSerial(Year(d), Month(d) + 1, 1), "yyyymm")
        Else
            MsgBox "アクティブシートが月のシートではありません"
            Exit Sub
        End If
    End With
    On Error Resume Next
    Set ws = Worksheets(sh_name)
    On Error GoTo 0
    If Not ws Is Nothing Then
        MsgBox "次月のシートは既に存在します"
        ws.Move After:=ActiveSheet
        Worksheets(Format(d, "yyyymm")).Activate
        Exit Sub ' 処理終了
    End If

    ActiveSheet.Copy After:=ActiveSheet
    With ActiveSheet
        .Name = sh_name
        n = .Range("C" & .Rows.Count).End(xlUp).Row
        If n >= 4 Then .Range("B4:Q" & n).ClearContents ' 範囲を消去
        .Range("I4:I35").Formula = "=IF(G4>0,F4-G4,"""")"
        .Range("N4:N35").Formula = "=IF(RC[-3]>0,RC[-7]-RC[-3]-RC[-2]-RC[-1],"""")" 
        .Range("O4:O35").Formula = "=IF(RC[-1]="""","""",RC[-1]*1.08)
    End With

    ' ｢B4｣にシートネームから取得し日付書込
     Range("B4").Value = DateAdd(????, sh_name)

End Sub

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

sh_nameと同様の方法でdから求めてもよいのでは。

 Sub test()
    Dim d As Date

    d = Date
    MsgBox DateSerial(Year(d), Month(d) + 2, 0)

 End Sub

（マナ） 2015/02/24(火) 20:16

ちょいと整形。

 Sub test()
    Dim sh_name As String
    Dim d As Date
    Dim ws As Worksheet
    Dim n As Long

    With ActiveSheet
        If Len(.Name) = 6 And IsDate(Left(.Name, 4) & "/" & Right(.Name, 2) & "/1") Then
            d = DateSerial(Left(.Name, 4), Right(.Name, 2), 1)
            sh_name = Format(DateAdd("m", 1, d), "yyyymm")
        Else
            MsgBox "アクティブシートが月のシートではありません"
            Exit Sub
        End If
    End With

    On Error Resume Next
    Set ws = Worksheets(sh_name)
    On Error GoTo 0
    If Not ws Is Nothing Then
        MsgBox "次月のシートは既に存在します"
        ws.Move After:=ActiveSheet
        Worksheets(Format(d, "yyyymm")).Activate
        Exit Sub ' 処理終了
    End If

    ActiveSheet.Copy After:=ActiveSheet
    With ActiveSheet
        .Name = sh_name
        n = .Range("C" & .Rows.Count).End(xlUp).Row
        If n >= 4 Then .Range("B4:Q" & n).ClearContents ' 範囲を消去
        .Range("I4:I35").Formula = "=IF(G4>0,F4-G4,"""")"
        .Range("N4:N35").Formula = "=IF(RC[-3]>0,RC[-7]-RC[-3]-RC[-2]-RC[-1],"""")"
        .Range("O4:O35").Formula = "=IF(RC[-1]="""","""",RC[-1]*1.08)"
        .Range("B4").Value = DateAdd("m", 2, d) - 1     ' ｢B4｣にシートネームから取得し日付書込
    End With
 End Sub
（???） 2015/02/25(水) 09:18

マナさん
？？？さん
ありがとうございます。
どちらもうまくいきました。(^_^)
追加で、すみませんが翌月のシートを作成した段階で
ランダムにシートタブカラーを変えるマクロ追加できないでしょうか？
現状は前月のシートタブカラーそのままですが
よろしくお願いします。
（nobu） 2015/02/25(水) 10:18

 横から失礼します。

 【ランダムにシートタブカラーを変える】

 ランダムに変えたい理由がいまいち、わからないのですが？
 むしろ、１月は青、２月は黄色、３月は水色、・・・といったように１２か月分を決めておけば
 色を見るだけで何月のシートなのかが直感的にわかるのでは？と思いますが。

 仮に、【ランダム】だとして、xl2013で使用可能な色は 0 ～　16,777,216 あるわけで、
 これらのなかから、どの色でもいい、ランダムに？　意図しないような色が選ばれるかもしれませんよ。
 それでよければ、乱数で、0 ～　16,777,216　の整数の間から１つ取り出すことはできますけどね。

 同じランダムでも、候補を、たとえば２０種億ぐらいに決めておいて、1～20の整数を取り出して
 １なら　赤、２なら青　といったような制御のほうが現実的？

 でも、それなら、月別に色を決めておいたほうがよろしいかと思いますが？

（β） 2015/02/25(水) 10:42

βさん
仰るとおりです。
以下のように色決めたのですが
よろしくお願いします。
１月　赤
２月　青
３月　緑
４月　濃黄色
５月　水色
６月　薄緑
７月　黄色
８月　任意色
９月　：
10月　：
11月　：
12月　：
（nobu） 2015/02/25(水) 11:08

 日付書き込みした直後あたりに、以下を追加。
        .Tab.Color = Array(vbRed, vbBlue, vbGreen, &H99FFFF, vbCyan, &H99FF99, vbYellow, vbBlack, vbWhite, vbMagenta, &HF0B000, &H50D092)(Month(d) - 1)
（???） 2015/02/25(水) 13:07

 ランダムっぽい順番より、規則性のある色のほうが綺麗に見えると思いますが、いかが？
        .Tab.Color = Array(&HFF&, &H40FF&, &H80FF&, &HB0FF&, &HFF00&, &HFF40&, &HFF80&, &HFFB0&, &HFF0000, &HFF4000, &HFF8000, &HFFB000)(Month(DateAdd("m", 1, d)) - 1)
（???） 2015/02/25(水) 13:37

 お遊びです。
 運用としては、回答されたものの方がいいと思います。

 新規シートに下記コードを置いて、A1 をダブルクリックすると遊べます。
 以降はA列に色をつけると、シートを変更したタイミングで、反映します。

 Private Sub Worksheet_Activate()
    Columns("A").Clear
    For i = 1 To Worksheets.Count
        Cells(i, "A").Interior.Color = Worksheets(i).Tab.Color
    Next
 End Sub

 Private Sub Worksheet_Deactivate()
    If Range("A1").Interior.Pattern = xlNone Then Exit Sub
    For i = 1 To Worksheets.Count
        Worksheets(i).Tab.Color = Cells(i, "A").Interior.Color
    Next
 End Sub

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim cl
    If Target.Address = "$A$1" Then
        For i = 1 To Worksheets.Count
            cl = RGB(Int(256 * Rnd()), Int(256 * Rnd()), Int(256 * Rnd()))
            Worksheets(i).Tab.Color = cl
            Cells(i, "A").Interior.Color = cl
        Next
        Cancel = True
    End If
 End Sub
（Mook） 2015/02/25(水) 14:05

？？？さん
返事遅くなりました。
ありがとうございます。
無事、色付けできました。識別し易いです

Mookさん
おもしろいですね
何かお遊びbookに利用させていただきます。
質問完了と致します。

回答者の皆様ありがとうございました。
（nobu） 2015/02/25(水) 18:11

コメント返信：

[ 一覧(最新更新順) ]

[[20150224195048]] 『月を加算したシートネームから値を書き込みたい』（nobu） ページの最後に飛ぶ

[[20150224195048]]　『月を加算したシートネームから値を書き込みたい』（nobu）　ページの最後に飛ぶ