VBA：連続範囲データを６行飛ばし３列飛ばしで転記するマクロ

お久しぶりです。

またぼちぼち更新していきます。

さて、ネットで探しても見当たらなかったマクロです。

連続データを配列に格納して、６行、３列飛ばしに転記するマクロです。

校務での使い道は、

時間割表を週案シートに展開転記する時などに使えると思います。

奇数、偶数シートで転記内容を変えられるようにしてみました。

一瞬で転記できます。

コードとサンプルシートを載せてみました。無駄なところがあるかもしれませんが、

一応動きますのでご勘弁を。

--------------------------------------------------------------------------------

Option Explicit

Sub ■配列展開6行飛ばし3列飛ばし()

Dim myarr, rng As Range
Dim r, c As Long
Dim ws1, sh As Worksheet

Application.ScreenUpdating = False '画面描画停止
Application.Calculation = xlCalculationManual '手動計算

For Each sh In Worksheets

With sh
If IsNumeric(.Name) = True Then 'シート名が数値ならば

Set ws1 = Worksheets("時間割")

'★シート名が奇数の場合=======
If .Name Mod 2 = 1 Then
Set myarr = ws1.Range("B2:F7") '★コピー元配列範囲★

'★シート名が偶数の場合=======
ElseIf .Name Mod 2 = 0 Then
Set myarr = ws1.Range("I2:M7")
End If
r = 2 '★コピー先の先頭行番号
c = 3 '★コピー先の先頭列番号
For Each rng In myarr
If c <= 15 Then '★コピー先列の最大値までならば
.Cells(r, c) = rng 'コピー先にrngを転記
c = c + 3 '列方向に規則性でずらしていく
Else '列最大値を超えたら
'---------------------------------------------------
r = r + 6 '★行方向に規則性を足して下がる
c = 3 '★先頭列に戻す★
'---------------------------------------------------
.Cells(r, c) = rng 'コピー先にrngを転記
c = c + 3 '列方向に規則性でずらしていく
End If
Next
'====================================

End If
End With

Application.Calculation = xlCalculationAutomatic '自動計算にもどす

MsgBox "処理完了！"

End Sub

Sub 処理クリアー()

Dim myarr, rng As Range
Dim r, c As Long
Dim ws1, sh As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each sh In Worksheets

With sh
If IsNumeric(.Name) = True Then
Set ws1 = Worksheets("時間割")
Set myarr = ws1.Range("B102:F107") '★コピー元空白範囲★
r = 2
c = 3
For Each rng In myarr
If c <= 15 Then
.Cells(r, c) = rng
c = c + 3
Else
'------------------------
r = r + 6
c = 3
'------------------------
.Cells(r, c) = rng
c = c + 3
End If
Next
End If
End With