fork download
copy 
  1. Option Explicit
  2.  
  3. Public Sub 合計シート設定()
  4.     Dim gks As Worksheet
  5.     Dim wk_num As Variant
  6.     Dim wk_num2 As Variant
  7.     Dim ws As Worksheet
  8.     Dim wrow As Long
  9.     Dim wcol As Long
  10.     Set gks = Worksheets("合計")
  11.     gks.Range("B2:J10").ClearContents
  12.     wk_num = check_week(gks.Range("A1").Value)
  13.     If wk_num = 0 Then
  14.         MsgBox ("曜日不正:" & gks.Range("A1").Value)
  15.         Exit Sub
  16.     End If
  17.     For Each ws In Worksheets
  18.         If ws.Name = "合計" Then Exit For
  19.         wk_num2 = check_date(ws.Name)
  20.         If wk_num2 = 0 Then
  21.             MsgBox ("シートの日付不正:" & ws.Name)
  22.             Exit Sub
  23.         End If
  24.         If wk_num = wk_num2 Then
  25.             For wrow = 2 To 10
  26.                 For wcol = 2 To 10
  27.                     gks.Cells(wrow, wcol).Value = gks.Cells(wrow, wcol).Value + ws.Cells(wrow, wcol).Value
  28.                 Next
  29.             Next
  30.         End If
  31.     Next
  32.     MsgBox ("合計シート設定完了")
  33. End Sub
  34. Public Sub 抽出シート設定()
  35.     Dim cys As Worksheet
  36.     Dim wk_num As Variant
  37.     Dim wk_num2 As Variant
  38.     Dim ws As Worksheet
  39.     Dim wrow As Long
  40.     Dim wcol As Long
  41.     Dim dicT As Object
  42.     Dim key As Variant
  43.     Dim maxrow As Long
  44.     Set cys = Worksheets("抽出")
  45.     cys.Range("B:ZZ").ClearContents
  46.     wk_num = check_week(cys.Range("A1").Value)
  47.     If wk_num = 0 Then
  48.         MsgBox ("曜日不正:" & cys.Range("A1").Value)
  49.         Exit Sub
  50.     End If
  51.     maxrow = cys.Cells(Rows.Count, 1).End(xlUp).Row    '最大行取得
  52.     If maxrow < 3 Then
  53.         MsgBox ("抽出セル未設定")
  54.         Exit Sub
  55.     End If
  56.     Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  57.     For wrow = 3 To maxrow
  58.         key = cys.Cells(wrow, "A").Value
  59.         If dicT.exists(key) = True Then
  60.             MsgBox ("抽出セル重複:" & key)
  61.             Exit Sub
  62.         End If
  63.         If check_cellname(key) = False Then
  64.             MsgBox ("抽出セル不正:" & key)
  65.             Exit Sub
  66.         End If
  67.         dicT(key) = wrow
  68.     Next
  69.     wcol = 2
  70.     For Each ws In Worksheets
  71.         If ws.Name = "合計" Then Exit For
  72.         wk_num2 = check_date(ws.Name)
  73.         If wk_num2 = 0 Then
  74.             MsgBox ("シートの日付不正:" & ws.Name)
  75.             Exit Sub
  76.         End If
  77.         If wk_num = wk_num2 Then
  78.             cys.Cells(1, wcol).Value = cys.Cells(1, 1).Value    '曜日
  79.             cys.Cells(2, wcol).Value = "'" & ws.Name            'シート名
  80.             wrow = 3
  81.             For Each key In dicT.keys
  82.                 cys.Cells(wrow, wcol).Value = ws.Range(key).Value
  83.                 wrow = wrow + 1
  84.             Next
  85.             wcol = wcol + 1
  86.         End If
  87.     Next
  88.     MsgBox ("抽出シート設定完了")
  89. End Sub
  90.  
  91. '曜日チェック（"日", "月", "火", "水", "木", "金", "土"の何れかであること）
  92. Private Function check_week(ByVal wk As String) As Variant
  93.     Dim wk_arr As Variant
  94.     Dim i As Integer
  95.     check_week = 0
  96.     wk_arr = Array("日", "月", "火", "水", "木", "金", "土")
  97.     For i = 0 To UBound(wk_arr)
  98.         If wk = wk_arr(i) Then
  99.             check_week = i + 1
  100.             Exit Function
  101.         End If
  102.     Next
  103. End Function
  104. '日付チェック（西暦下2桁+月2桁＋日2桁であること、暦日上存在すること）
  105. Private Function check_date(ByVal yymmdd As String) As Variant
  106.     Dim wdate As Date
  107.     Dim wdate_str As String
  108.     check_date = 0
  109.     If Len(yymmdd) <> 6 Then Exit Function
  110.     If IsNumeric(yymmdd) = False Then Exit Function
  111.     wdate_str = "20" & Left(yymmdd, 2) & "/" & Mid(yymmdd, 3, 2) & "/" & Right(yymmdd, 2)
  112.     If IsDate(wdate_str) = False Then Exit Function
  113.     wdate = CDate(wdate_str)
  114.     check_date = Weekday(wdate)
  115. End Function
  116. '抽出セル名チェック(B2～J10であること)
  117. Private Function check_cellname(ByVal cellname As String)
  118.     Dim wlen As Long
  119.     Dim wstr1 As String
  120.     Dim wstr2 As Long
  121.     check_cellname = False
  122.     wlen = Len(cellname)
  123.     If wlen < 2 Or wlen > 3 Then Exit Function
  124.     wstr1 = Left(cellname, 1)
  125.     wstr2 = Right(cellname, wlen - 1)
  126.     If wstr1 < "B" Or wstr1 > "J" Then Exit Function
  127.     If IsNumeric(wstr2) = False Then Exit Function
  128.     If CLng(wstr2) < 2 Or CLng(wstr2) > 10 Then Exit Function
  129.     check_cellname = True
  130. End Function
  131.  
  132.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/ST6tgZ
language:
Text (text 6.10)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!