見出し画像

(excel)少数列のデータを複数個ページ内に再配置する方法

(excel)少数列のデータを複数個ページ内に再配置する方法の例をChatGPTに作ってもらいましたので共有します。
あまり、汎用性のあるVBAにはなっていないのですが、どなたかのお役に立てると幸いです。

Sub RearrangeAndFormatPages()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim pageHeight As Long
    Dim newRow As Long
    Dim i As Long, j As Long
    Dim copyStartRow As Long
    Dim copyEndRow As Long
    Dim newSheetName As String
    Dim counter As Integer

    ' 元のシートを設定
    Set wsSource = ThisWorkbook.Sheets("Sheet2") ' 参照元シート名を指定

    ' 新しいシートの名前を設定
    newSheetName = "Result"
    counter = 1
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Sheets(newSheetName)
    Do While Not wsTarget Is Nothing
        newSheetName = "Result" & counter
        counter = counter + 1
        Set wsTarget = Nothing
        Set wsTarget = ThisWorkbook.Sheets(newSheetName)
    Loop
    On Error GoTo 0

    ' 新しいシートを作成
    Set wsTarget = ThisWorkbook.Sheets.Add
    wsTarget.Name = newSheetName
    
    ' 元のシートの最終行を取得
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    
    ' ページあたりの行数を設定
    pageHeight = 35 ' 1ページの行数に合わせて調整(例: 35行)
    
    ' 新しいシートの開始行を設定
    newRow = 1
    
    ' ページごとに処理を繰り返す
    For i = 1 To lastRow Step pageHeight * 5
        For j = 0 To 4
            copyStartRow = i + j * pageHeight
            copyEndRow = Application.Min(copyStartRow + pageHeight - 1, lastRow)
            
            ' コピーする範囲がデータの範囲を超えていないか確認
            If copyStartRow <= lastRow Then
                ' 元のページを新しいシートにコピー(A, B列を5つ並べる)
                wsSource.Range(wsSource.Cells(copyStartRow, 1), wsSource.Cells(copyEndRow, 2)).Copy _
                Destination:=wsTarget.Cells(newRow, j * 2 + 1) ' j * 2 で列をずらしてコピー

                ' 改行したところに太線を引く
                If j > 0 Then
                    wsTarget.Cells(newRow - 1, j * 2 + 1).Resize(1, 2).Borders(xlEdgeTop).Weight = xlThick
                End If
            End If
        Next j
        ' 新しいシートの行をページ分だけ増やす
        newRow = newRow + (copyEndRow - copyStartRow + 1)
    Next i
End Sub

サポートをお願いします! 漢検準1級の参考書を買いたいです。