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


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

回答の条件
  • 1人2回まで
  • 登録:2009/04/03 03:09:52
  • 終了:2009/04/04 18:17:42

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3430ベストアンサー獲得回数9692009/04/03 15:06:39

ポイント100pt

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

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

id:WATANABE

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

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

2009/04/04 13:26:51

その他の回答(3件)

id:tm343 No.1

tm343回答回数55ベストアンサー獲得回数102009/04/03 07:12:27

ポイント1pt

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


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

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


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

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


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

http://okwave.jp/qa3084643.html

id:v86 No.2

v86回答回数2ベストアンサー獲得回数02009/04/03 07:05:37

ポイント1pt

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

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


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

id:SALINGER No.3

SALINGER回答回数3430ベストアンサー獲得回数9692009/04/03 15:06:39ここでベストアンサー

ポイント100pt

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

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

id:WATANABE

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

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

2009/04/04 13:26:51
id:SALINGER No.4

SALINGER回答回数3430ベストアンサー獲得回数9692009/04/04 15:29:11

ポイント20pt

追加箇所とある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
id:WATANABE

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

2009/04/04 18:16:59

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません