「教えて!ピックアップ」リリース!

エクセルで2000行ほどある一枚のシートを50行ごとに
(1-50)(51-100)(101-150)…と分割して、一つずつ
新しいブックで保存する作業があります。

今までは50行ごとにコピーして新しいブックにペーストを
繰り返してましたが、大量にきたもので困ってます。
何か自動化などできないことでしょうか?
ご回答お待ちしております。

参考にシートは以下のような形式です。
  A  B  C  D
1  a  1   1  1
2  b  1   2  3
3  c  2   3  4
4  d  5   6  7
5  e  7   8  9
6  f  2   3  4 
7  h  5   6  7
8  g  8   9  1
9  n  2   3  4
10 n  5   6  7



50 j  5   6  7

A 回答 (2件)

> エクセルで50行ごとに区切ったデータをシートに分割したい


> …と分割して、一つずつ新しいブックで保存する作業があります。

「ブック」と「シート」のどちらか不明瞭ですが、アクティブシートを50行毎に
新しいブックにコピーするコードです。

アクティブブックと同じフォルダに保存されます。


Option Explicit

Sub Sample()
  
  Dim Wb     As Workbook
  Dim rngData   As Range
  Dim i      As Long
  Dim strBasename As String
  Dim strFilename As String
  Dim lng1stRow  As Long
  Dim lngLstRow  As Long
  
  Const STEP_ROWS_COUNT = 50 '50 行
  
  Set rngData = ActiveSheet.UsedRange
  strBasename = ActiveWorkbook.FullName
   
  With rngData
    lng1stRow = .Row
    lngLstRow = Application.Ceiling(.Cells(.Cells.Count).Row, STEP_ROWS_COUNT)
  End With
  Application.ScreenUpdating = False
  For i = lng1stRow To lngLstRow Step STEP_ROWS_COUNT
    ' 新規ブック作成
    Set Wb = Workbooks.Add
    ' STEP_ROWS_COUNT で指定された行ごとに新規ブックの Sheet1 にコピー
    rngData.Rows(CStr(i) & ":" & CStr(i + STEP_ROWS_COUNT - 1)).Copy _
      Destination:=Wb.Worksheets("Sheet1").Range("A1")
    ' 新規ファイル名生成
    strFilename = Left$(strBasename, InStrRev(strBasename, ".") - 1) & "(" _
          & Format$(i, "0000") & "-" & Format$(i + STEP_ROWS_COUNT - 1, "0000") _
          & ").xls"
    ' 同一フォルダに保存して閉じる
    Wb.SaveAs Filename:=strFilename
    Wb.Close
    Set Wb = Nothing
  Next i
  Set rngData = Nothing

End Sub
    • good
    • 1
この回答へのお礼

マクロがよく分からないので、悪戦苦闘のうえ、
無事に成功できました。凄いですね!

ファイルが番号順の名前で出来てきたときは
驚きと嬉しさでいっぱいでした。
マクロを作っていただき大変助かりました。

ほんとうに有難うございました。

お礼日時:2006/07/29 11:54

以下のようなマクロで可能です。


対象のシートは1枚であると仮定しています。
(あまりテストしてないのでバグがあるかもしれません)
---
Sub test()
Dim m As Long
Dim r As Long
Dim n As String
n = ActiveWorkbook.Name
'コピー単位
m = 50
'最終行取得
r = Range("A65536").End(xlUp).Row
'最終行がコピー単位より大きい間繰り返し
Do While r > m
'コピー単位より大きい部分を切り取り
Rows(CStr(m + 1) & ":" & CStr(r)).Cut
'新しいシートを作成
Sheets.Add After:=Worksheets(Worksheets.Count)
'新しいシートに貼り付け
Rows("1:1").Insert Shift:=xlDown
'最終行を取得
r = Range("A65536").End(xlUp).Row
Loop
'シートが1つになるまで繰り返し
Do While Worksheets.Count > 1
'最後のシートを新しいブックに移動
Sheets(Worksheets.Count).Move
'最初のブックに戻る
Windows(n).Activate
Loop
End Sub
    • good
    • 0
この回答へのお礼

マクロはよく分からないんですが、ちょっとうまく
動いてくれませんでした。途中で止まりました。
どこが悪いかもよく分かりませんが、
お手数かけて
作っていただき有難うございました。

お礼日時:2006/07/29 11:47

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


人気Q&Aランキング