fork download
copy 
  1. Option Explicit
  2.  
  3. Dim sh1 As Worksheet    'バラシシート
  4. Dim sh2 As Worksheet    '短冊シート
  5. Public Sub 短冊シート設定5()
  6.     Dim maxrow1 As Long
  7.     Dim maxrow2 As Long
  8.     Dim max_box As Long
  9.     Dim i As Long
  10.     Dim wrow As Long
  11.     Dim boxNo As Long
  12.     Dim seqNo As Long
  13.     Dim box_row As Long
  14.     Dim box_col As Long
  15.     Dim pv As String
  16.     Dim y As Long
  17.     Set sh1 = Worksheets("バラシ")
  18.     Set sh2 = Worksheets("短冊")
  19.     maxrow1 = sh1.Cells(Rows.count, "S").End(xlUp).row   'S列の最大行取得
  20.     If maxrow1 < 2 Then Exit Sub
  21.     maxrow2 = sh2.Cells(Rows.count, "A").End(xlUp).row  'A列の最大行取得
  22.     If (maxrow2 + 1) Mod 7 <> 0 Then
  23.         MsgBox ("マス番号の行が不正")
  24.         Exit Sub
  25.     End If
  26.     max_box = ((maxrow2 + 1) \ 7) * 3
  27.     '短冊シートのマスをクリア
  28.     For i = 1 To max_box
  29.         Call clear_box(i)
  30.     Next
  31.     'バラシシートを処理
  32.     boxNo = 1
  33.     seqNo = 0
  34.     pv = ""
  35.     For wrow = 2 To maxrow1
  36.         If sh1.Cells(wrow, "S").Value = "" Then
  37.             If seqNo > 0 Then
  38.                 boxNo = boxNo + 2
  39.                 seqNo = 0
  40.                 pv = ""
  41.             End If
  42.         Else
  43.             '日付の設定
  44.             If seqNo = 0 Then
  45.                 Call get_pos_in_box(boxNo, 1, box_row, box_col)
  46.                 sh2.Cells(box_row + 1, box_col).NumberFormatLocal = "@"
  47.                 sh2.Cells(box_row + 1, box_col).Value = sh1.Cells(wrow, "A").Value
  48.                 sh2.Cells(box_row + 1, box_col).Font.Color = -16776961
  49.             End If
  50.             seqNo = seqNo + 1
  51.             If (seqNo Mod 4) <> 1 And pv <> sh1.Cells(wrow, "S").Value Then
  52.                 y = (seqNo - 1) \ 4
  53.                 seqNo = (y + 1) * 4 + 1
  54.             End If
  55.             If seqNo > 24 Then
  56.                 boxNo = boxNo + 1
  57.                 seqNo = 1
  58.             End If
  59.             'マス番号とマス内番号に対応する位置を取得
  60.             Call get_pos_in_box(boxNo, seqNo, box_row, box_col)
  61.             '該当位置へS列データを設定
  62.             sh2.Cells(box_row, box_col).Value = sh1.Cells(wrow, "S").Value
  63.             sh2.Cells(box_row, box_col).Interior.Color = sh1.Cells(wrow, "S").Interior.Color
  64.             pv = sh1.Cells(wrow, "S").Value
  65.         End If
  66.     Next
  67.     MsgBox ("完了")
  68. End Sub
  69.  
  70. '指定マスクリア
  71. Private Sub clear_box(ByVal box_no As Long)
  72.     Dim box_row As Long
  73.     Dim box_col As Long
  74.     Dim i As Long
  75.     For i = 1 To 24
  76.         Call get_pos_in_box(box_no, i, box_row, box_col)
  77.         sh2.Cells(box_row, box_col).ClearContents
  78.         sh2.Cells(box_row, box_col).Interior.Pattern = xlNone
  79.     Next
  80.     '日付クリア
  81.     Call get_pos_in_box(box_no, 1, box_row, box_col)
  82.     sh2.Cells(box_row + 1, box_col).ClearContents
  83.     sh2.Cells(box_row + 1, box_col).NumberFormatLocal = "G/標準"
  84.     sh2.Cells(box_row + 1, box_col).Font.ColorIndex = xlAutomatic
  85. End Sub
  86. '指定マス内の指定位置取得
  87. Private Sub get_pos_in_box(ByVal box_no As Long, ByVal seq_no As Long, ByRef box_row As Long, ByRef box_col As Long)
  88.     Dim x1 As Long                  'box_noに対応する列ブロックインデックス
  89.                                     'box_no=1,4,7  =>0
  90.                                     'box_no=2,5,8  =>1
  91.                                     'box_no=3,6,9  =>2
  92.  
  93.     Dim x2 As Long                  'seq_noに対応する列ブロック内インデックス
  94.                                     'seq_no=1,5,9  =>3
  95.                                     'box_no=2,6,10 =>2
  96.                                     'box_no=3,7,11 =>1
  97.                                     'box_no=4,8,12 =>0
  98.  
  99.     Dim y1 As Long                  'box_noに対応する行ブロックインデックス
  100.                                     'box_no=1～3  =>0
  101.                                     'box_no=4～6  =>1
  102.                                     'box_no=7～10 =>2
  103.  
  104.     Dim y2 As Long                  'seq_noに対応する行ブロック内インデックス
  105.                                     'seq_no=1～4   =>5
  106.                                     'seq_no=5～8   =>4
  107.                                     'seq_no=9～12  =>3
  108.                                     'seq_no=13～16 =>2
  109.                                     'seq_no=17～20 =>1
  110.                                     'seq_no=21～24 =>0
  111.  
  112.     y1 = (box_no - 1) \ 3           'y1はbox_noから1を引いた結果を3で割った値（余りは切り捨て）
  113.     y2 = 5 - ((seq_no - 1) \ 4)     'y2は5-(seq_noから1を引いた結果を4で割った値（余りは切り捨て）)・・・ここを変更
  114.     box_row = y1 * 7 + 1 + y2       '指定マスの行はy1を7倍して、1加算し、更にy2を加算した値
  115.     x1 = (box_no - 1) Mod 3         'x1はbox_noから1を引いた結果を3で割った余り
  116.     x2 = 3 - ((seq_no - 1) Mod 4)   'x2は3-(seq_noから1を引いた結果を4で割った余り)・・・・ここを変更
  117.     box_col = x1 * 5 + 2 + x2       '指定マスの列はx1を5倍して、2加算し、更にx2を加算した値
  118. End Sub
  119.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/YnzCEP
language:
Text (text 6.10)
created:
2 years ago
visibility:
secret

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!