Excel VBA質問箱 IV

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

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


45587 / 76732 ←次へ | 前へ→

【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

14 hits

【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 回答

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