Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9006 / 13646 ツリー ←次へ | 前へ→

【29856】sheet_activateでの日付の自動挿入について 溜息吐息 05/10/14(金) 22:12 質問[未読]
【29858】Re:sheet_activateでの日付の自動挿入につ... 赤色吐息 05/10/14(金) 23:31 発言[未読]
【29862】Re:sheet_activateでの日付の自動挿入に... ponpon 05/10/15(土) 0:33 発言[未読]
【29874】Re:sheet_activateでの日付の自動挿入に... PI 05/10/15(土) 11:35 発言[未読]
【29875】Re:sheet_activateでの日付の自動挿入に... ponpon 05/10/15(土) 11:56 発言[未読]
【29864】Re:sheet_activateでの日付の自動挿入につ... awu 05/10/15(土) 1:40 回答[未読]

【29856】sheet_activateでの日付の自動挿入につい...
質問  溜息吐息  - 05/10/14(金) 22:12 -

引用なし
パスワード
   宜しくお願いします。

BOOKをopenしたときに外部ファイルを取り込むように設定しています。
その時、sheet3のA1にyyyy年m月という具合で日付取り込まれるように
設定してあります。

そこでsheet_activateにてsheet3を開いたときに
A1のyyyy年m月を元に、A3:A33の範囲にm月d日という具合で一ヶ月の日付を自動入力させたく思います。

その方法について何方かアドバイス頂けませんでしょうか

【29858】Re:sheet_activateでの日付の自動挿入に...
発言  赤色吐息  - 05/10/14(金) 23:31 -

引用なし
パスワード
   ▼溜息吐息 さん:
'A1 に年、B1に月を入力するとRange("A4:A35")に日付を入力するマクロを見つけました。
B1には、=Today()・・・書式の設定で例えば10月に変更して活用されては?
後はアレンジしてください。


Private Sub Worksheet_Change(ByVal Target As Range)
 Dim themonth As Integer
 Dim theyear As Integer
 Dim days As Integer
With Target
  If IsEmpty(.Value) Then Exit Sub
  If Not IsNumeric(.Value) Then Exit Sub
  If .Count > 1 Then Exit Sub
    Application.EnableEvents = False
  If .Address(0, 0) = "A1" Or .Address(0, 0) = "B1" Then   
   If Range("A1").Value <> "" And Range("B1").Value <> "" And _
  IsNumeric(Range("A1").Value) And IsNumeric(Range("B1").Value) Then  
     Range("A4:A35").ClearContents
     theyear = Range("A1").Value
     themonth = WorksheetFunction.RoundDown(Range("B1").Value, 0)  
     If themonth >= 1 And themonth <= 12 Then
      With Range("A4")        
      For days = 1 To Day(DateSerial(theyear, themonth + 1, 1) - 1)
       .Offset(days - 1).Value = DateSerial(theyear, themonth, days)
         Next
      End With
     Else
      MsgBox "月の値は、1〜12を入力してください。"
       Range("B1").Select
     End If
    End If
   End If
End With
Application.EnableEvents = True

End Sub

【29862】Re:sheet_activateでの日付の自動挿入に...
発言  ponpon  - 05/10/15(土) 0:33 -

引用なし
パスワード
   こんばんは。

>sheet3のA1にyyyy年m月
は、シリアル値でしょうか? それなら
なんとかできているようですが、もっとスマートな方法があるかもしれません。

Private Sub Worksheet_Activate()
  Dim myDate As Date
  Dim Cnt As Integer

  myDate = DateValue(Range("A1").Value)
  If Not IsEmpty(Range("A3")) Then
    Range("A3", Range("A65536").End(xlUp)).ClearContents
  End If
  Cnt = DateSerial(Year(myDate), Month(myDate) + 1, 1) - DateSerial(Year(myDate), Month(myDate), 1)
  For i = 1 To Cnt
   Cells(i + 2, 1).Value = Format(DateValue(Month(myDate) & "/" & i), "m月d日")
  Next
End Sub

【29864】Re:sheet_activateでの日付の自動挿入に...
回答  awu  - 05/10/15(土) 1:40 -

引用なし
パスワード
   > そこでsheet_activateにてsheet3を開いたときに・・・

Worksheet_Activateイベントのことでいいのですね。

> sheet3のA1にyyyy年m月

一応、セルA1が、日付形式でも文字列でも構わないようにしました。

こんな感じで如何でしょうか。


Private Sub Worksheet_Activate()
Dim N As Integer
Dim AryD(0 To 30, 0)
Dim SetDate As Date
If IsDate(Range("A1").Text & "1日") Then
  SetDate = DateValue(Range("A1").Text & "1日")
  Do While Month(DateValue(Range("A1").Text & "1日")) = Month(SetDate)
    AryD(N, 0) = SetDate
    SetDate = SetDate + 1
    N = N + 1
  Loop
End If
With Range("A3:A33")
  .NumberFormatLocal = "m月d日"
  .Value = AryD
End With
End Sub

【29874】Re:sheet_activateでの日付の自動挿入に...
発言  PI  - 05/10/15(土) 11:35 -

引用なし
パスワード
   ▼ponpon さん:

>Private Sub Worksheet_Activate()
>  Dim myDate As Date
>  Dim Cnt As Integer

この下のコードでエラーが出ますが・・・どのようにすれば
良いでしょうか?
>  myDate = DateValue(Range("A1").Value)
>  If Not IsEmpty(Range("A3")) Then
>    Range("A3", Range("A65536").End(xlUp)).ClearContents
>  End If
>  Cnt = DateSerial(Year(myDate), Month(myDate) + 1, 1) - DateSerial(Year(myDate), Month(myDate), 1)
>  For i = 1 To Cnt
>   Cells(i + 2, 1).Value = Format(DateValue(Month(myDate) & "/" & i), "m月d日")
>  Next
>End Sub

【29875】Re:sheet_activateでの日付の自動挿入に...
発言  ponpon  - 05/10/15(土) 11:56 -

引用なし
パスワード
   こんにちは。
どこでどんなメッセージのエラーがでるのか教えてください。
コードのどこが黄色くなっていますか?
もう一度こちらでtestしましたがA1が文字列でも大丈夫なようです。

今から出かけますので、返信は夜になります。
awuさんからも回答が付いています。そちらをおためしください。

9006 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free