人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルについての質問です。

項目が20程度ある元データを一行ずつブックに分けたいと考えています。
2000件ほどありますので、手作業で無く効率よくこなせる方法を教えて下さい。

1238695789
●拡大する

●質問者: WATANABE
●カテゴリ:コンピュータ インターネット
✍キーワード:エクセル データ
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● tm343
●1ポイント

検証してませんが、以下のURLを参考にしてみてはいかがでしょうか?


エクセルでブックの分割をするマクロ?

http://questionbox.jp.msn.com/qa500099.html


エクセルのブック分割マクロを教えてください。

http://oshiete1.goo.ne.jp/qa2205349.html


エクセルで各シート毎にブックに分割したい

http://okwave.jp/qa3084643.html


2 ● v86
●1ポイント

エクセルのブック分割マクロを教えてください。

http://oshiete1.goo.ne.jp/qa2205349.html


これが参考になると思います


3 ● SALINGER
●100ポイント ベストアンサー

2000件ほどあるということで、ブックが2000個あるとは考えづらいので、

A列には同じファイル名もあり、同じファイル名の場合は横に名前が並んでいくということでよろしいでしょうか。

図のように2行目に見出しがあり、3行目からデータが入っているとして作ってみました。

分割されたファイルが入るフォルダを指定して、実行してみてください。


Option Explicit

Sub SepBook()
  'aaa.xlsやccc.xlsのあるフォルダを指定
 Const wbPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test"
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wbName As String
 Dim fldName() As String
 Dim fldData() As String
 Dim lastRow As Long
 Dim lastCol As Integer
 Dim lastCol2 As Integer
 Dim i As Integer
 Dim j As Integer
 
 Set ws = ActiveSheet
 lastCol = ws.Cells(2, Columns.Count).End(xlToLeft).Column
 
 ReDim fldName(lastCol - 1)
 ReDim fldData(lastCol - 1)
 
 For i = 0 To lastCol - 1
 fldName(i) = ws.Cells(2, i + 1).Value
 Next i
 
 lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
 For i = 3 To lastRow
 For j = 0 To lastCol - 1
 fldData(j) = ws.Cells(i, j + 1)
 Next
 
 If Dir(wbPath & "\" & fldData(0) & ".xls") <> "" Then
 Set wb = Workbooks.Open(wbPath & "\" & fldData(0) & ".xls")
 Else
 Set wb = Workbooks.Add
 End If

 With wb.Worksheets(1)
 lastCol2 = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
 For j = 1 To lastCol - 1
 If lastCol2 = 2 Then
 .Cells(j, 1).Value = fldName(j)
 End If
 .Cells(j, lastCol2).Value = fldData(j)
 Next
 End With
 
 Application.DisplayAlerts = False
 wb.SaveAs (wbPath & "\" & fldData(0) & ".xls")
 Application.DisplayAlerts = True
 wb.Close
 Next

End Sub

不都合がある場合は、コメント欄をオープンしていただければ対応します。

◎質問者からの返答

毎回ありがとうございます、希望通りの事ができました。

ちなみですけれど項目の一番目のセルの書式を数値にしたいのですが、マクロの何処を変更すればよいのでしょうか?


4 ● SALINGER
●20ポイント

追加箇所とある3行を追加しました。

説明してませんでしたが、ブックが無ければ作成、既にブックがある場合は追記になってます。

ブックが開けない場合のエラートラップはしていないので、aaa.xlsなどのブックは閉じて実行してください。

Sub SepBook()
  'aaa.xlsやccc.xlsのあるフォルダを指定
 Const wbPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test"
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wbName As String
 Dim fldName() As String
 Dim fldData() As String
 Dim lastRow As Long
 Dim lastCol As Integer
 Dim lastCol2 As Integer
 Dim i As Integer
 Dim j As Integer
 
 Set ws = ActiveSheet
 lastCol = ws.Cells(2, Columns.Count).End(xlToLeft).Column
 
 ReDim fldName(lastCol - 1)
 ReDim fldData(lastCol - 1)
 
 For i = 0 To lastCol - 1
 fldName(i) = ws.Cells(2, i + 1).Value
 Next i
 
 lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
 For i = 3 To lastRow
 For j = 0 To lastCol - 1
 fldData(j) = ws.Cells(i, j + 1)
 Next
 
 If Dir(wbPath & "\" & fldData(0) & ".xls") <> "" Then
 Set wb = Workbooks.Open(wbPath & "\" & fldData(0) & ".xls")
 Else
 Set wb = Workbooks.Add
 End If

 With wb.Worksheets(1)
 lastCol2 = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
 For j = 1 To lastCol - 1
 If lastCol2 = 2 Then
 .Cells(j, 1).Value = fldName(j)
 End If
 
  '///////追加箇所
 If j = 1 Then
 .Cells(j, lastCol2).NumberFormatLocal = "0_ "
 End If
  '////////////////
 
 .Cells(j, lastCol2).Value = fldData(j)
 Next
 End With
 
 Application.DisplayAlerts = False
 wb.SaveAs (wbPath & "\" & fldData(0) & ".xls")
 Application.DisplayAlerts = True
 wb.Close
 Next

End Sub
◎質問者からの返答

丁寧にありがとうございます。とても助かりました。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ