エクセルのシートに記入されたリストを分割する

Summary

エクセルのシートに記入された一行一レコードのリストを分割する

たとえば

これを

こんな感じで

VBAでのコード

たとえばこんな感じ

自作の関数とariawaseというライブラリを使ってますが、お好みで。

Option Explicit

''' ワークシートに記載されたレコードを３つのワークシートに転記する
''' リスト分割
Public Sub DivideList()

    Dim n As Long: n = 3

    ''' くだものシートからレコードを配列にする
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("リスト")
    Dim header: header = ws.Rows(1): koffeeArray.ArrayBase0_2ndDimension header ''' 配列ベースはゼロにする
    Dim body: body = ArrSlice(GetVal(ws.Range("A2").CurrentRegion), 1)

    ''' くだもの n　シートを削除する
    Dim vv As Worksheet, rgx As Object: Set rgx = CreateRegExp("リスト\d.*")
    For Each vv In Worksheets
        If rgx.Test(vv.Name) Then
            koffeeExcel.DeleteSheet vv.Name
        End If
    Next

    ''' 分割した配列をそれぞれのシートに貼り付ける
    Dim v, tmpWs As Worksheet, i As Long: i = 1
    For Each v In ArrayWindow(body, n)

        ''' くだもの n シートを作成する
        Set tmpWs = koffeeExcel.AddSheet("リスト" & CStr(i))
        tmpWs.Cells.NumberFormat = "@"

        ''' レコードを記入する
        PutVal header, tmpWs.Range("A1")
        PutVal v, tmpWs.Range("A2")

        ''' 色づけ
        tmpWs.Range(tmpWs.Cells(1, 1), tmpWs.Cells(1, UBound(header(0)) + 1)).Interior.Color = RGB(200, 200, 200)
        ''' セルの幅調整
        tmpWs.Columns.AutoFit

        i = i + 1
    Next v

End Sub

分割する関数　ArrayWindow

サンプルはこんな感じ

''' 配列を３分割にする
Sub Sample_div3_array()

    ''' 配列を分割する数字
    Dim n As Long: n = 3

    ''' 配列を用意
    Dim arr(): arr = Array(1, 2, 3, 4, 5, 6, 7, 8)

    ''' 配列を３分割にする関数
    Dim v
    For Each v In ArrayWindow(arr, n)
        Debug.Print Dump(v)
    Next v

End Sub

結果

Array(1%, 2%, 3%)
Array(4%, 5%, 6%)
Array(7%, 8%)

元になる関数

Public Function ArrayWindow(ByVal arr As Variant, ByVal GroupN As Variant) As Variant

    ' Array(1..10) divided by 3
    ' -------------------------
    ' => Array(1%, 2%, 3%, 4%)
    ' => Array(5%, 6%, 7%)
    ' => Array(8%, 9%, 10%)

    ''' dependence: ariawase Core.ArrSlice


    ''' guard
    If Not IsArray(arr) Then Err.Raise 13
    If ArrRank(arr) > 1 Then Err.Raise 13
    If LBound(arr) < 0 Then Err.Raise 13

    ''' guard2( GroupN )
    Select Case GroupN
        Case Is <= 0: Err.Raise 13
        Case Is = 1:  ArrayWindow = Array(arr): GoTo Ending
        Case Is >= (UBound(arr) + 1)
            Dim tmpArray(): tmpArray = Array(): ReDim tmpArray(0 To UBound(arr))
            Dim idx As Long
            For idx = 0 To UBound(arr)
                tmpArray(idx) = Array(arr(idx))
            Next idx
            ArrayWindow = tmpArray
            GoTo Ending
        Case Else
            GoTo ArrayWindowImpl
    End Select


ArrayWindowImpl:

    Dim groupIndex As Long: groupIndex = Int(ArrLen(arr) / GroupN)
    Dim rest As Long: rest = ArrLen(arr) Mod GroupN

    ''' simple divison : e.g. 8 / 3 => array(2,2,2)
    Dim groupIndexArray(): groupIndexArray = Array(): ReDim groupIndexArray(0 To GroupN - 1)
    Dim i As Long
    For i = 0 To GroupN - 1
        groupIndexArray(i) = groupIndex
    Next i

    ''' add weight 1 : e.g. 8 / 3 => array(3,3,2)
    If Not rest = 0 Then
        Dim j As Long
        For j = 0 To rest - 1
            groupIndexArray(j) = groupIndexArray(j) + 1
        Next j
    End If

    ''' slice array by group index
    Dim ary(): ary = Array(): ReDim ary(0 To GroupN - 1)
    Dim k As Long, acc_idx As Long
    For k = 0 To UBound(groupIndexArray)
        ary(k) = Core.ArrSlice(arr, acc_idx, acc_idx + groupIndexArray(k) - 1)
        acc_idx = acc_idx + groupIndexArray(k)
    Next k

    ArrayWindow = ary

Ending:
End Function

現場からは以上です