1000行以上あるデータを50行前後の行で転記したい

Question

実現したいこと

1000行以上あるExcelの表で見た目をわかりやすくするために、50行前後で区切って同シート内に転記したい。

発生している問題・分からないこと

添付画像のように、グループごとに行数が異なるExcelの表があり、
見た目をわかりやすくするため、50行前後の表に変更したいのですが、
変更後の表の行数が一定にはならないので、コードの書き換え方がわかりません。

下記ソースコードは100行ごとにデータ分割して別シートへコピーに掲載されていたものです。

また、下記のコードは100行ごとに別シートを作成し、転記していくものですが、
可能でしたら、同シート内で転記・変換する方法も知りたいです。

該当のソースコード

Sub データを100行ごとに分割する()
    Dim シート As Worksheet, 元 As Worksheet '元は元データのあるシート
    Dim 総行数 As Long, 回数 As Long, i As Long, 開始行 As Long
    Const コピー行 = 100
    Set 元 = ActiveSheet '変数の元をActiveSheetにセットする
    総行数 = 元.UsedRange.Rows.Count
    回数 = Int(総行数 / コピー行) + IIf(総行数 Mod コピー行 > 0, 1, 0)
    開始行 = 1
    For i = 1 To 回数
        Set シート = Sheets.Add
        シート.Name = 開始行 & "～" & 開始行 + コピー行 - 1
        元.Rows(開始行 & ":" & 開始行 + コピー行 - 1).Copy シート.Range("A1") 
        Columns("A:F").AutoFit
        開始行 = 開始行 + コピー行
    Next i
End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

特定の行数で転記する方法は多く見つけられたのですが、
行数がランダムになる場合の方法を見つけることができませんでした。

追記

参考画像2

Comments

[logres_Fan]

最大列数を意識していますか？

[tatsu99]

あなたが提示されたコードは、以下のようになっています。
１．元のデータを１００行単位で、他のシートにコピーする。
２．コピー対象となる列は記述されている列が全て対象となる。
３．元のデータの１行目からコピーする。
あなたの要望は以下のようになっています。
１．元のデータを５０行単位で同じシートにコピーする。
２．コピー対象となる列は、A、Bの２列のみである。
３．元のデータの２行目からコピーする。コピー先は、G2のセルから開始する。
上記で間違いないでしょうか。
その場合、仕様がかなり変わるので、作り直しになるかと思います。

[shibakoppe]

>>logres_Fan様
ご覧いただきありがとうございます。
最大列数は意識しておりません。
ですが、データ数が多すぎるものに関しては100行前後に変更し、列数を少なくしようとは考えています。

[shibakoppe]

>>tatsu99様
ご覧いただきありがとうございます。
私が実現したことはtatsu99様がまとめてくださった通りです。
仰る通り、仕様が大きく異なるものの為、提示コードでは方向性が全く異なるのですが、どう調べても私では類似コードが見つけられず、このコードを書き換えて対応してみようと思った次第です。
拙い文章の中、余計にわかりにくくしてしまい申し訳ございません。

[shibakoppe]

ご回答皆様、本当にありがとうございました。
tatsu99様も親身にご対応いただき厚く御礼申し上げます。

Answer 1

一度、トライをお願いします。

Sub データを50行ごとに分割する()
    Dim シート As Worksheet, 元 As Worksheet '元は元データのあるシート
    Dim 総行数 As Long, 回数 As Long, i As Long, 開始行 As Long
    Const コピー行 = 50
    Set 元 = ActiveSheet '変数の元をActiveSheetにセットする
    総行数 = 元.UsedRange.Rows.Count
    回数 = Int(総行数 / コピー行) + IIf(総行数 Mod コピー行 > 0, 1, 0)
    開始行 = 1
    For i = 1 To 回数
        Set シート = Sheets.Add
        シート.Name = 開始行 & "～" & 開始行 + コピー行 - 1
        If i < 回数 Then
            元.Rows(開始行 & ":" & 開始行 + コピー行 - 1).Copy シート.Range("A1")
        Else
            ' 最後のセクションの場合、残りの行数をコピー
            Dim 残り行数 As Long
            残り行数 = 総行数 - 開始行 + 1
            元.Rows(開始行 & ":" & 開始行 + 残り行数 - 1).Copy シート.Range("A1")
        End If
        Columns("A:F").AutoFit
        開始行 = 開始行 + コピー行
    Next i
End Sub

元のデータを50行ごとに分割し、最後のセクションに関しては残りの行数をコピーします。

Comments

[shibakoppe]

コードをご提示いただきありがとうございます。
試してみたのですが、最後のセクションに関しては手動でコピーということですよね…？
使用する者が私だけではないため、手動での作業は可能な限り避けたいと考えておりまして…

Answer 2

次のコードの動作を確認してみていただけますか。

Option Explicit
Sub splitData()
  ' 初期設定
  Const limitRows As Long = 48 '分割の区切り(適宜調整)
  Const startRow As Long = 2 'データの開始行
  Const startCol As Long = 7 '転記の開始列

  ' 振分処理
  Dim sheet As Worksheet
  Set sheet = ThisWorkbook.Worksheets("Sheet1")
  With sheet
  
    ' 区切りとなるグループ番号がある行番号のリストを作成
    Dim lastRow As Long
    lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Dim indexes As Variant
    indexes = .Range("A" & startRow & ":A" & lastRow).Value
    Dim rowsColl As Collection  '区切りとなるグループ番号の行のリスト
    Set rowsColl = New Collection
    Dim rowsCount As Long
    rowsCount = limitRows
    Dim i As Long
    Dim groupNumRow As Long 'グループ番号の行
    For i = 1 To UBound(indexes, 1)
      groupNumRow = i + startRow - 1
      If Not indexes(i, 1) = "" Then
        If groupNumRow > rowsCount Then
          rowsColl.Add groupNumRow
          rowsCount = rowsCount + limitRows
        End If
      End If
    Next i
    rowsColl.Add lastRow + 1 '最終行の次の行を追加
    

    ' 区切りの行数を超えたグループまでをコピー
    Dim beginRow As Long 'コピーの開始行
    Dim beginCol As Long 'ペーストの開始列
    Dim endRow As Variant '次のグループの開始行
    beginCol = startCol
    beginRow = startRow
    For Each endRow In rowsColl
      .Range("A" & beginRow & ":B" & endRow - 1).Copy .Cells(startRow, beginCol)
      beginRow = endRow '開始行更新
      beginCol = beginCol + 2 '右に2列移動
    Next endRow
  End With
End Sub

Comments

[shibakoppe]

ご回答いただきありがとうございます。
思っていた通りに作成することができました！
本当にありがとうございます！

Answer 3

質問へのコメントで確認した通りの動作になります。
同じシートにコピーします。
対象となるシートは、アクティブシート（表示されているシート）になります。

Option Explicit

Public Sub データ転記()
    Const CUNIT As Long = 50    '50行単位で転記
    Dim ws As Worksheet
    Dim maxrow As Long
    Dim src_row As Long
    Dim trg_row As Long
    Dim trg_col As Long
    Dim count As Long
    Set ws = ActiveSheet
    maxrow = ws.Cells(Rows.count, "B").End(xlUp).Row             'B列の最終行を求める
    trg_row = 2
    trg_col = 7
    count = 0
    For src_row = 2 To maxrow
        ws.Cells(trg_row, trg_col).Resize(, 2).Value = ws.Cells(src_row, 1).Resize(, 2).Value
        count = count + 1
        trg_row = trg_row + 1
        If count >= CUNIT And ws.Cells(trg_row, 1).Value <> "" Then
            count = 0
            trg_col = trg_col + 2
            trg_row = 2
        End If
    Next
    MsgBox ("完了")
End Sub

Comments

[shibakoppe]

ご回答いただき、ありがとうございます。
お教えいただいたコードを試してみたのですが、グループの途中で列が変わってしまいました…。
(参考画像を追記として載せさせていただきます。)
この場合、どのように修正すればよいでしょうか…？

[tatsu99]

同じグループは同じ列に格納するように変更しました。

[shibakoppe]

何度も申し訳ありません。
変更していただいたとのことで、再度試してみましたが、うまくいきませんでした…
50行ごとに区切られてしまい、グループの途中で列が変わってしまいます…

[tatsu99]

グループ番号が同じ場合、そのA列のセルは空白セルになっている前提です。
グループ番号　名前
1　　　　　　　□□□
1　　　　　　　×××
1　　　　　　　※※※
2　　　　　　　□□□
2　　　　　　　×××
2　　　　　　　※※※
のようになっている場合は、正しく動作しません。
グループ番号は上記のようになっているのでしょうか。