Excel VBA質問箱 IV

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

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


7907 / 13644 ツリー ←次へ | 前へ→

【36019】コード簡略化のアドバイスを 春まき 06/3/19(日) 4:45 質問[未読]
【36021】Re:コード簡略化のアドバイスを Hirofumi 06/3/19(日) 9:04 発言[未読]
【36022】速い! 春まき 06/3/19(日) 10:08 お礼[未読]
【36055】再質問 春まき 06/3/20(月) 10:59 質問[未読]
【36065】Re:土日を青罫線で囲みたい かみちゃん 06/3/20(月) 13:06 回答[未読]
【36110】御返事遅くなりました 春まき 06/3/21(火) 0:40 お礼[未読]
【36111】Re:土日を青罫線で囲みたい かみちゃん 06/3/21(火) 10:44 発言[未読]
【36134】何度もすいません 春まき 06/3/22(水) 2:55 お礼[未読]
【36068】Re:再質問 Jaka 06/3/20(月) 13:35 発言[未読]
【36108】Jaka 様 春まき 06/3/21(火) 0:22 回答[未読]
【36135】使う上司の都合なんて知りませんが...。 Jaka 06/3/22(水) 9:34 発言[未読]
【36157】Re:使う上司の都合なんて知りませんが...。 春まき 06/3/22(水) 22:55 お礼[未読]
【36102】Re:再質問 Hirofumi 06/3/20(月) 19:54 回答[未読]
【36103】Re:再質問 かみちゃん 06/3/20(月) 20:14 発言[未読]
【36105】Re:再質問 Hirofumi 06/3/20(月) 22:25 回答[未読]

【36019】コード簡略化のアドバイスを
質問  春まき  - 06/3/19(日) 4:45 -

引用なし
パスワード
   横長のカレンダーで、C5からAG5まで曜日が入れてあり、曜日は月を変えると関数で変わるようにしてあります。土日の4列から31列まで自動的に青太の罫線で囲むようにしたいのですが、条件付き書式は使い切っているのでマクロを使うことにしました。
なんとか以下のコードで動かすことができましたが、とても遅いのです。
自分でも色々省略したのですが、他に方法がありましたらご指導お願いいたします。
(変数宣言より上の行は罫線の初期化をしています。)

Range(Cells(4, 3), Cells(31, 33)).Select
  Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  With Selection.Borders(xlEdgeLeft)
    .Weight = xlHairline
    .ColorIndex = xlAutomatic
  End With
  With Selection.Borders(xlEdgeTop)
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Selection.Borders(xlEdgeBottom)
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Selection.Borders(xlEdgeRight)
    .Weight = xlHairline
    .ColorIndex = xlAutomatic
  End With
  With Selection.Borders(xlInsideVertical)
    .Weight = xlHairline
    .ColorIndex = xlAutomatic
  End With

  Dim kei As Integer
  For kei = 3 To 33
  Select Case Cells(5, kei)
  Case Is = 7
  Range(Cells(4, kei), Cells(31, kei)).Select
  With Selection.Borders(xlEdgeLeft)
    .Weight = xlMedium
    .ColorIndex = 11
  End With
  With Selection.Borders(xlEdgeTop)
    .Weight = xlMedium
    .ColorIndex = 11
  End With
  With Selection.Borders(xlEdgeBottom)
    .Weight = xlMedium
    .ColorIndex = 11
  End With

  Case Is = 1
  Range(Cells(4, kei), Cells(31, kei)).Select
  With Selection.Borders(xlEdgeTop)
    .Weight = xlMedium
    .ColorIndex = 11
  End With
  With Selection.Borders(xlEdgeBottom)
    .Weight = xlMedium
    .ColorIndex = 11
  End With
  With Selection.Borders(xlEdgeRight)
    .Weight = xlMedium
    .ColorIndex = 11
  End With
  End Select
  Next kei

【36021】Re:コード簡略化のアドバイスを
発言  Hirofumi  - 06/3/19(日) 9:04 -

引用なし
パスワード
   たったら1ヶ月分だから、元のままでも支障は無いのでは?
遅いと言っても高が知れている?
ただ少し、コードを整理して見ました(多分速くは、成っていませんが?)

Option Explicit

Sub Test()
 
  Dim rngCurrent As Range
  Dim kei As Integer
  
  Set rngCurrent = ActiveSheet.Cells(4, 3)
  
  Application.ScreenUpdating = False
  
  With rngCurrent
    With .Resize(28, 31)
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
      With .Borders(xlEdgeLeft)
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlEdgeTop)
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlEdgeBottom)
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlEdgeRight)
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlInsideVertical)
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
      End With
    End With
    '青太線の出力
    For kei = 2 To 32
      With .Offset(, kei).Resize(28)
        Select Case .Item(2, 1).Value
          Case Is = 7
            With .Borders(xlEdgeLeft)
              .Weight = xlMedium
              .ColorIndex = 11
            End With
            With .Borders(xlEdgeTop)
              .Weight = xlMedium
              .ColorIndex = 11
            End With
            With .Borders(xlEdgeBottom)
              .Weight = xlMedium
              .ColorIndex = 11
            End With
          Case Is = 1
            With .Borders(xlEdgeTop)
              .Weight = xlMedium
              .ColorIndex = 11
            End With
            With .Borders(xlEdgeBottom)
              .Weight = xlMedium
              .ColorIndex = 11
            End With
            With .Borders(xlEdgeRight)
              .Weight = xlMedium
              .ColorIndex = 11
            End With
        End Select
      End With
    Next kei
  End With

  Set rngCurrent = Nothing
  
  Application.ScreenUpdating = True
  
End Sub

【36022】速い!
お礼  春まき  - 06/3/19(日) 10:08 -

引用なし
パスワード
   Hirofumiさん、ありがとうございます。
どのくらい速さが違うのか試してみました。した所、驚きました、明らかにグンと速い。
罫線初期化だけのマクロも作ってあるんですが、私のそれより半分ぐらいの速さで動いてます。勉強不足でどの辺でそんなに速いのかよくわかりませんが
Application.ScreenUpdating = False
だけでもかなり早くなっている感じです。

ありがたく使わせていただきます。厚くお礼申し上げます。

【36055】再質問
質問  春まき  - 06/3/20(月) 10:59 -

引用なし
パスワード
   Hirofumiさんの直してくださったコードを使っていたところ1日と2日に土日が来る場合(4月や7月)、その最初の土日(1日と2日、セル番地はC5とD5)に反応していない事がわかりました。
自分で直そうと思ったのですが、私の持っている本(エクセルVBA基礎編)には載っていない記述がちらほらあり困難です。どうかアドバイス願います。

【36065】Re:土日を青罫線で囲みたい
回答  かみちゃん E-MAIL  - 06/3/20(月) 13:06 -

引用なし
パスワード
   こんにちは。かみちゃん です。

横から失礼します。

> Hirofumiさんの直してくださったコードを使っていたところ1日と2日に土日が来る場合(4月や7月)、その最初の土日(1日と2日、セル番地はC5とD5)に反応していない

私もカレンダーをよく使っていますので、コードを検証してみました。
以下の部分を修正するとうまく動きます。
ただし、小の月、うるう年の処理は必要ないのでしょうか?

Sub Test()
 '〜省略〜
 With rngCurrent
  '〜省略〜
  '青太線の出力
  '--- 修正
  'For kei = 2 To 32
  For kei = 0 To 30
  '--------
   With .Offset(, kei).Resize(28)
    Select Case .Item(2, 1).Value
     Case Is = 7
      '〜省略〜
      '--- 追加
      If kei = 30 Then
       With .Borders(xlEdgeRight)
        .Weight = xlMedium
        .ColorIndex = 11
       End With
      End If
      '--------
     Case Is = 1
      '--- 追加
      If kei = 0 Then
       With .Borders(xlEdgeLeft)
        .Weight = xlMedium
        .ColorIndex = 11
       End With
      End If
      '--------
      '〜省略〜
    End Select
   End With
  Next kei
 End With

 Set rngCurrent = Nothing
 Application.ScreenUpdating = True
End Sub

【36068】Re:再質問
発言  Jaka  - 06/3/20(月) 13:35 -

引用なし
パスワード
   どんな風に関数や条件付書式が入っているのか解りませんが
全てマクロで1週間分だけ作って、残りはフィルでいいと思いますけど....。

【36102】Re:再質問
回答  Hirofumi  - 06/3/20(月) 19:54 -

引用なし
パスワード
   ▼春まき さん:
> Hirofumiさんの直してくださったコードを使っていたところ1日と2日に土日が来る場合(4月や7月)、その最初の土日(1日と2日、セル番地はC5とD5)に反応していない事がわかりました。
>自分で直そうと思ったのですが、私の持っている本(エクセルVBA基礎編)には載っていない記述がちらほらあり困難です。どうかアドバイス願います。

ゴメン!!!!
此れは、私のチョンボ!
基準位置からのOffsetに直したのを忘れていました
以下の様に修正して下さい

此れ間違い

    '青太線の出力
    For kei = 2 To 32

此れが正解

    '青太線の出力
    For kei = 1 To 31

【36103】Re:再質問
発言  かみちゃん  - 06/3/20(月) 20:14 -

引用なし
パスワード
   Hirofumiさん、こんにちは。かみちゃん です。

>此れが正解
>
>    '青太線の出力
>    For kei = 1 To 31

僭越ながら、[#36065]で、私が検証させていただいたのですが、
C5〜AG5には、WEEKDAY関数で曜日を示す1〜7の整数が入っている場合、
たとえば、C4に2006/4/1、C5に=WEEKDAY(C4)としてある場合ですと、
>    For kei = 1 To 31
では、春まきさんが求めている結果にならないと思います。

私は、
 For kei = 0 To 30
としないといけないのでは?
と考えたのですが、何かおかしいところありますでしょうか?
また、その月が日曜日で始まったり、土曜日で終わったりすると、端の線の処理を
どうするかという問題もあるかと思いました。

いずれにしろ、動くかどうかを仕様確認するのは、春まきさん次第なのですが・・・

何か、ご指摘等アドバイスありましたら、お教えいただけると幸いです。

【36105】Re:再質問
回答  Hirofumi  - 06/3/20(月) 22:25 -

引用なし
パスワード
   ▼かみちゃん さん:
>Hirofumiさん、こんにちは。かみちゃん です。
>
>>此れが正解
>>
>>    '青太線の出力
>>    For kei = 1 To 31
>
>僭越ながら、[#36065]で、私が検証させていただいたのですが、
>C5〜AG5には、WEEKDAY関数で曜日を示す1〜7の整数が入っている場合、
>たとえば、C4に2006/4/1、C5に=WEEKDAY(C4)としてある場合ですと、
>>    For kei = 1 To 31
>では、春まきさんが求めている結果にならないと思います。
>
>私は、
> For kei = 0 To 30
>としないといけないのでは?
>と考えたのですが、何かおかしいところありますでしょうか?
>また、その月が日曜日で始まったり、土曜日で終わったりすると、端の線の処理を
>どうするかという問題もあるかと思いました。
>
>いずれにしろ、動くかどうかを仕様確認するのは、春まきさん次第なのですが・・・
>
>何か、ご指摘等アドバイスありましたら、お教えいただけると幸いです。

ゴメン、まだ勘違いしていました
かみちゃん さんの言う通り、

For kei = 0 To 30

が有って居ます

【36108】Jaka 様
回答  春まき  - 06/3/21(火) 0:22 -

引用なし
パスワード
   ▼Jaka さん:
>どんな風に関数や条件付書式が入っているのか解りませんが
>全てマクロで1週間分だけ作って、残りはフィルでいいと思いますけど....。

レスありがとうございます。
来月部署移動なので大がかりな変更をしている余裕がないのです。
私作る人、使う人は上司でエクセルはほとんど知らず
注文だけする人です。(;_;)

【36110】御返事遅くなりました
お礼  春まき  - 06/3/21(火) 0:40 -

引用なし
パスワード
   かみちゃん様 ご指導ありがとうございます。
>私もカレンダーをよく使っていますので、コードを検証してみました。
>以下の部分を修正するとうまく動きます。

検証ご苦労かけました。修正したところ問題解決できました。
ありがたく使わせていただきます。

>ただし、小の月、うるう年の処理は必要ないのでしょうか?

小の月は4月や6月のことでしょうか。31日は条件付き書式で1日になった場合
白塗りで見えなくなります。データー部分も白塗りになり、青太線発動した場合
空欄がぐりっと囲まれますが、この機能は老眼対策なのでデーターのない
部分の細かいことは不問とされるので大丈夫です。

いつもご指導ありがとうございます。ご厚情に大変感謝しております。

【36111】Re:土日を青罫線で囲みたい
発言  かみちゃん E-MAIL  - 06/3/21(火) 10:44 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>ただし、小の月、うるう年の処理は必要ないのでしょうか?
>
>小の月は4月や6月のことでしょうか。31日は条件付き書式で1日になった場合
>白塗りで見えなくなります。データー部分も白塗りになり、青太線発動した場合
>空欄がぐりっと囲まれますが、この機能は老眼対策なのでデーターのない
>部分の細かいことは不問とされるので大丈夫です。

「小の月」の定義は、国語辞書で調べてください。
大辞林には、次のように記載されています。
 日数が三〇日以下の月。二月・四月・六月・九月・一一月。
 陰暦では、日数が二九日以下の月をいう。

31日の処理は、白塗りにしているということですが、本当にそれでいいのでしょうか?
うるう年の処理のことも考慮されていないように思いますし、
何の対策かどうかはよくわかりませんが、「細かいことは不問とされる」という点
が非常に気になります。
ちなみに、私は、罫線で囲むのではなく、土日祝日に網掛けしています。

また、カレンダーについては、以下のURLにも詳しく説明されており、私も勉強
させていただいているので、参考にされてはいかがでしょうか?
http://www.h3.dion.ne.jp/~sakatsu/index.htm
http://www.h3.dion.ne.jp/~sakatsu/CalendarTopic.htm
http://www.kenzo30.com/ex_kisotoku/ex_ks_tokubetu_sk7.htm

以上、春まきさんが今後困ることにならないためにも、気になったので、コメント
させていただきました。

【36134】何度もすいません
お礼  春まき  - 06/3/22(水) 2:55 -

引用なし
パスワード
   かみちゃん 様何度も丁寧なレスありがとうございます。

>大辞林には、次のように記載されています。
自分で辞書を引くべきでした。お世話かけました。

>31日の処理は、白塗りにしているということですが、本当にそれでいいのでしょうか?
>うるう年の処理のことも考慮されていないように思いますし、

間違えました。白塗りではなくてフォントを白くして見かけ上空欄になるようにしてあります。関数の構成はかみちゃんさんの【36103】の推測通りです。例えば2月30日などは1日の表示になってしまうのですが、条件付き書式でセルの値が30
以外はフォントを白にと設定してあるので、うるう年でも小の月でも本来表示されるべき以外の日が出れば空欄になります。曜日部分も同様です。
データー部分は存在しない日には必然的に入力されず空欄になります。

>何の対策かどうかはよくわかりませんが、「細かいことは不問とされる」という点
>が非常に気になります。

前述のように存在しない日は全て空欄になります。データーのある部分の
土日は見分けしやすいように青枠が入るようにしているわけですが、データーのない日はチェックの必要もないので青枠があってもなくてもかまわないとされるという意味です。

>ちなみに、私は、罫線で囲むのではなく、土日祝日に網掛けしています。
プリンターの印刷は網掛けでもいいのですが、コピーも取っています。
コピーだと網掛け内の文字が読みにくくなりますので使えないのです。

>以上、春まきさんが今後困ることにならないためにも、気になったので、コメント
>させていただきました。

重ね重ねのご指導幸甚に思います。ありがとうございました。

【36135】使う上司の都合なんて知りませんが...。
発言  Jaka  - 06/3/22(水) 9:34 -

引用なし
パスワード
   こんな感じでもいいんじゃないか、って言う手法です。
上から書いているので、レイアウトなどは全然違いますよ。

Sub karen2()
Dim Dday As String, Nen As Integer, Tuk As Integer, Resz As Integer
Dim kyusai As Variant, StrtRag As String, STRow As Long
StrtRag = "A2:B2"
Range(StrtRag).Resize(31).Clear
Nen = 2006 'Range("A1").Value
Tuk = 3  'Range("B1").Value
Dday = Format(DateSerial(Nen, Tuk, 1), "yyyy/m/d")
Range(StrtRag).Cells(1).Value = Dday
Range(StrtRag).Cells(2).Value = Format(Dday, "aaa")
Resz = Format(DateSerial(Nen, Tuk + 1, 1) - 1, "d")
'Application.ScreenUpdating = False
With Range(StrtRag)
  .AutoFill Destination:=.Resize(7), Type:=xlFillDefault
End With
STRow = Range(StrtRag).Row
For i = STRow To STRow + 6
  With Cells(i, 1)
    If WeekDay(.Value) = "7" Then
     .Resize(, 2).Interior.ColorIndex = 8
    ElseIf WeekDay(.Value) = "1" Then
     .Resize(, 2).Interior.ColorIndex = 7
    End If
  End With
Next
With Range(StrtRag).Resize(7)
  .AutoFill Destination:=.Resize(Resz), Type:=xlFillDefault
End With
罫線

If MsgBox("祝日、振替も入れる?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
kyusai = HolidayTBL2(Nen)
For i = STRow To Resz + 1
  With Cells(i, 1)
    Mct = Application.Match(Format(.Value, "yyyy/m/d"), kyusai, 0)
    If Not (IsError(Mct)) Then
      .Resize(, 2).Interior.ColorIndex = 7
    End If
  End With
Next
'Application.ScreenUpdating = True
End Sub

Private Function HolidayTBL2(ByVal SachYear As Long) As Variant
  Dim FixHoliday As Variant, WekDy As Long, SVSt As String
  Dim CagJan As Long, CagJul As Long, CagSep As Long, TBC As Long
  Dim Equx39 As Long, TBL() As Variant, SacWek As Long
  Dim i As Long, ii As Long

  FixHoliday = Array("1/1", "2/11", "4/29", "5/3", "5/4", "5/5", _
           "11/3", "11/23", "12/23")
  TBC = -1
  For i = 0 To UBound(FixHoliday)
    If WeekDay(SachYear & "/" & FixHoliday(i)) <> 1 Then
     TBC = TBC + 1
     ReDim Preserve TBL(TBC)
     TBL(UBound(TBL)) = SachYear & "/" & FixHoliday(i)
    ElseIf Not (Right(FixHoliday(i), 3) = "5/3" Or Right(FixHoliday(i), 3) = "5/4") Then
     If WeekDay(SachYear & "/" & FixHoliday(i)) = 1 Then
       TBC = TBC + 1
       ReDim Preserve TBL(TBC)
       TBL(UBound(TBL)) = Format(CDate(SachYear & "/" & FixHoliday(i)) + 1, "yyyy/m/d")
     End If
    End If
  Next
 
  WekDy = WeekDay(SachYear & "/1/1", vbSunday)
  SacWek = 2
  If WekDy <= 2 Then
   CagJan = 2 - WekDy + ((SacWek - 1) * 7) + 1
  Else
   CagJan = 8 - WekDy + ((SacWek - 1) * 7) + 2
  End If
  ReDim Preserve TBL(UBound(TBL) + 1)
  TBL(UBound(TBL)) = SachYear & "/1/" & CagJan

  WekDy = WeekDay(SachYear & "/7/1", vbSunday)
  SacWek = 3
  If WekDy <= 2 Then
   CagJul = 2 - WekDy + ((SacWek - 1) * 7) + 1
  Else
   CagJul = 8 - WekDy + ((SacWek - 1) * 7) + 2
  End If
  ReDim Preserve TBL(UBound(TBL) + 1)
  TBL(UBound(TBL)) = SachYear & "/7/" & CagJul

  WekDy = WeekDay(SachYear & "/9/1", vbSunday)
  SacWek = 3
  If WekDy <= 2 Then
   CagSep = 2 - WekDy + ((SacWek - 1) * 7) + 1
  Else
   CagSep = 8 - WekDy + ((SacWek - 1) * 7) + 2
  End If
  ReDim Preserve TBL(UBound(TBL) + 1)
  TBL(UBound(TBL)) = SachYear & "/9/" & CagSep

  WekDy = WeekDay(SachYear & "/10/1", vbSunday)
  SacWek = 2
  If WekDy <= 2 Then
   CagOct = 2 - WekDy + ((SacWek - 1) * 7) + 1
  Else
   CagOct = 8 - WekDy + ((SacWek - 1) * 7) + 2
  End If
  ReDim Preserve TBL(UBound(TBL) + 1)
  TBL(UBound(TBL)) = SachYear & "/10/" & CagOct

  Equx39 = Fix(20.8431 + 0.242194 * _
      (SachYear - 1980) - Fix((SachYear - 1980) / 4))
  ReDim Preserve TBL(UBound(TBL) + 1)
  TBL(UBound(TBL)) = SachYear & "/3/" & Equx39
 
  If WeekDay(TBL(UBound(TBL))) = 1 Then
   TBL(UBound(TBL)) = Format(CDate(TBL(UBound(TBL))) + 1, "yyyy/m/d")
  End If

  Equx39 = Fix(23.2488 + 0.242194 * _
      (SachYear - 1980) - Fix((SachYear - 1980) / 4))
  ReDim Preserve TBL(UBound(TBL) + 1)
  TBL(UBound(TBL)) = SachYear & "/9/" & Equx39

  If WeekDay(TBL(UBound(TBL))) = 1 Then
   TBL(UBound(TBL)) = Format(CDate(TBL(UBound(TBL))) + 1, "yyyy/m/d")
  End If

  If WeekDay(DateValue(SachYear & "/9/" & Equx39), vbSunday) = 4 Then
   ReDim Preserve TBL(UBound(TBL) + 1)
   TBL(UBound(TBL)) = SachYear & "/9/" & Equx39 - 1
  End If
 
  HolidayTBL2 = TBL
  Erase FixHoliday, TBL
  DoEvents
End Function

Sub 罫線()
  With Range("A2:B2").Resize(31)
    .Borders(xlEdgeLeft).Weight = xlThin
    .Borders(xlEdgeTop).Weight = xlThin
    .Borders(xlEdgeBottom).Weight = xlThin
    .Borders(xlEdgeRight).Weight = xlThin
    .Borders(xlInsideVertical).Weight = xlThin
    .Borders(xlInsideHorizontal).Weight = xlHairline
  End With
End Sub

【36157】Re:使う上司の都合なんて知りませんが.....
お礼  春まき  - 06/3/22(水) 22:55 -

引用なし
パスワード
   レスありがとうございます。

多量のコードを書いてくださってお手数かけさせました。
私としてはカレンダー機能、例えば土日や祝日、年末年始休
のフォント色変化などは条件付き書式で達成しているので
Hirofumi様やかみちゃん様の書いてくださったコードで
速いしボタンクリック1つで発動できるので満足しております。

お手数かけて申し訳ございませんでした。

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