| |
まず、元々のコードの何処が悪いのかを説明して置きます
これは、関連の無いループ（「For co1 = 1 To 40」、「For i = 1 To 400」）をネストした事によります
此れを分けるだけで、440回の代入だけに成りますので、相当速く成ります
Public Sub Sample3()
Dim i As Long
Dim co1 As Long
Dim co As Long
Dim cou As Long
Worksheets(Mys).Select
For i = 1 To 400
Select Case i
Case 1 To 10: co = 3: cou = 17
Case 11 To 20: co = 4: cou = 7
Case 21 To 30: co = 5: cou = -3
Case 31 To 40: co = 6: cou = -13
Case 41 To 50: co = 7: cou = -23
Case 51 To 60: co = 8: cou = -33
Case 61 To 70: co = 9: cou = -43
Case 71 To 80: co = 10: cou = -53
Case 81 To 90: co = 11: cou = -63
Case 91 To 100: co = 12: cou = -73
Case 101 To 110: co = 13: cou = -83
Case 111 To 120: co = 14: cou = -93
Case 121 To 130: co = 15: cou = -103
Case 131 To 140: co = 16: cou = -113
Case 141 To 150: co = 17: cou = -123
Case 151 To 160: co = 18: cou = -133
Case 161 To 170: co = 19: cou = -143
Case 171 To 180: co = 20: cou = -153
Case 181 To 190: co = 21: cou = -163
Case 191 To 200: co = 22: cou = -173
Case 201 To 210: co = 23: cou = -183
Case 211 To 220: co = 24: cou = -193
Case 221 To 230: co = 25: cou = -203
Case 231 To 240: co = 26: cou = -213
Case 241 To 250: co = 27: cou = -223
Case 251 To 260: co = 28: cou = -233
Case 261 To 270: co = 29: cou = -243
Case 271 To 280: co = 30: cou = -253
Case 281 To 290: co = 31: cou = -263
Case 291 To 300: co = 32: cou = -273
Case 301 To 310: co = 33: cou = -283
Case 311 To 320: co = 34: cou = -293
Case 321 To 330: co = 35: cou = -303
Case 331 To 340: co = 36: cou = -313
Case 341 To 350: co = 37: cou = -323
Case 351 To 360: co = 38: cou = -333
Case 361 To 370: co = 39: cou = -343
Case 371 To 380: co = 40: cou = -353
Case 381 To 390: co = 41: cou = -363
Case 391 To 400: co = 42: cou = -373
End Select
If Me.Controls("combobox2").Value = "4月" Then
If Me.Controls("CheckBox" & i).Value Then
Cells(co, i + cou).Value = "○"
Else
Cells(co, i + cou).Value = "×"
End If
ElseIf Me.Controls("combobox2").Value = "5月" Then
If Me.Controls("CheckBox" & i).Value Then
Cells(co, i + cou + 12).Value = "○"
Else
Cells(co, i + cou + 12).Value = "×"
End If
ElseIf Me.Controls("combobox2").Value = "6月" Then
If Me.Controls("CheckBox" & i).Value Then
Cells(co, i + cou + 24).Value = "○"
Else
Cells(co, i + cou + 24).Value = "×"
End If
End If
Next i
For co1 = 1 To 40
If Me.Controls("combobox2").Value = "4月" Then
Cells(co1 + 2, 17) = Me.Controls("label" & co1).Caption
ElseIf Me.Controls("combobox2").Value = "5月" Then
Cells(co1 + 2, 29) = Me.Controls("label" & co1).Caption
ElseIf Me.Controls("combobox2").Value = "6月" Then
Cells(co1 + 2, 41) = Me.Controls("label" & co1).Caption
End If
Next co1
End Sub
次に、「Select Case i」の部分が煩雑ので此れを整理します
其処で、１〜400まで1列に並んだ「CheckBox」を如何やって方形に並び替えるかを考えます
昔から、商を求める演算子「￥」と剰余を求める演算子「Mod」を使って、
1元の配列を2元に並べる定石の様な物が存在します
今回の場合、1〜400の番号を、10日毎のグループ分けを行う訳なのですが？
話を簡単にする為、0〜399の番号として考えます
iの値が0〜399まで変かする時
i = 0の時、0 \ 10 = 0、0 Mod 10 =0
i = 1の時、1 \ 10 = 0、1 Mod 10 =1
i = 2の時、2 \ 10 = 0、2 Mod 10 =2
・
・
i = 398の時、398 \ 10 = 39、398 Mod 10 =8
i = 399の時、399 \ 10 = 39、398 Mod 10 =9
と成り、「￥」はグループ番号（この場合「行」）、
「Mod」はグループ内の順位（この場合、「列」）を表します
また、Cellに対して１つづつ代入を行うと非常に遅く成るので、
配列を使って範囲に値を一遍に代入します
Public Sub Sample()
Dim i As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim vntResult1(1 To 40, 1 To 10) As Variant
Dim vntResult2(1 To 40, 1 To 1) As Variant
'CheckBoxの1〜400まで繰り返し
For i = 1 To 400
'配列の行位置を取得
lngRow = (i - 1) \ 10 + 1
'配列の列位置を取得
lngColumn = (i - 1) Mod 10 + 1
'CheckBoxのi番がTrueの場合
If Me.Controls("CheckBox" & i).Value Then
'配列のlngRow行、lngColumn列に"○"を代入
vntResult1(lngRow, lngColumn) = "○"
Else
vntResult1(lngRow, lngColumn) = "×"
End If
Next i
For i = 1 To 40
'Labelのi番の値を配列のi行目に代入
vntResult2(i, 1) _
= Me.Controls("Label" & i).Caption
Next i
With Worksheets(Mys)
'ComboBox2の値が
Select Case Me.Controls("combobox2").Value
Case "4月"
'基準位置からの列Offsetを0とする
lngColumn = 0
Case "5月"
lngColumn = 12
Case "6月"
lngColumn = 24
End Select
'基準位置から、lngColumn分右のセル位置を先頭として40×10の範囲に結果配列の値を代入
.Cells(3, 18 + lngColumn) _
.Resize(UBound(vntResult1, 1), _
UBound(vntResult1, 2)).Value = vntResult1
'基準位置から、lngColumn分右のセル位置を先頭として40×1の範囲に結果配列の値を代入
.Cells(3, 17 + lngColumn) _
.Resize(UBound(vntResult2, 1)).Value = vntResult2
End With
End Sub
|
|
Hirofumi
- 06/8/6(日) 23:02 -
