![見出し画像](https://assets.st-note.com/production/uploads/images/151507953/rectangle_large_type_2_2a1d407296bb310cf2af47e22a03f10a.jpeg?width=1200)
(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級の参考書を買いたいです。