研究で大量のデータ処理について、困っています。

1月毎で保存された毎時のエクセルデータがあり、行列の並び替えをしたいのですが、
どのようなマクロ処理をしたら良いか、勉強不足で分かりません。
データの処理内容は以下です。

①毎時(24時間)の毎日のデータが、1月毎に区切られた以下のようなブックがあります。

  A B C D E F G・・・・

2    ●年●月
3     1 2 3 4 ・・・31(日にち)
4    1 ● ●  ● ● ・・・・(データ)
5    2 ● ●  ● ● ・・・・(データ)
     ・
     ・
    24
   (時間)

②上のようなデータを日付と時間を入れ替え、1月ごとではなく、
日付順に全データをくっつけたエクセルを作りたいのです。

  A  B C D ・・・
1    1 2 3 ・・(時間)
2●/●/● ● ● ● ・・(データ)
3●/●/● ● ● ● ・・(データ)
  ・
  ・
(日にち)

データは1月毎で10年位(12ブック×10年)が4ケースあります。
これを1ケース1ブックことに行列の並び替えをしたいと思います。
よろしくお願い致します。

回答の条件
  • URL必須
  • 1人3回まで
  • 13歳以上
  • 登録:2010/02/25 01:02:14
  • 終了:2010/02/26 00:44:28

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912010/02/25 15:24:41

ポイント100pt

コメントが無効ですので、回答で失礼します。(コメントを有効にお願いします。)

下記の2か所を変更してみてください。

Sub MakeDataBook()
    Const filePath = "D:\DataFiles"  '★  実際のパスに修正
    Const DateCell = "B2"  '★  年月のデータセル :★★修正
 
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Application.ScreenUpdating = False
    Dim dstWS As Worksheet
    Set dstWS = Workbooks.Add().Worksheets(1)

    Dim wsNum As Long
    Dim xlFile As Object
    
    For Each xlFile In fso.GetFolder(filePath).Files
        If LCase(fso.GetExtensionName(xlFile.Path)) = "xls" Then
            With Workbooks.Open(xlFile.Path)
                With .Worksheets(1)
                    .Range("B3").Resize(30, 40).Copy
                     dstWS.Range("A1").Offset(40 * wsNum, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                     For i = 40 * wsNum + 1 To 40 * wsNum + 35
                         If dstWS.Cells(i, "A") <> "" Then
                             dstWS.Cells(i, "A") = CDate(.Range(DateCell) & dstWS.Cells(i, "A") & "日") ' ★★修正
                         End If
                     Next
                     wsNum = wsNum + 1
                End With
                .Close
            End With
        End If
    Next
 
 ' 表の整形
    dstWS.Range("A1").Resize(1, 40).EntireColumn.Sort Key1:=dstWS.Range("A1")
    dstWS.Rows(1).Insert
    dstWS.Range("A1").Resize(1, 24) = Array("", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24")
    dstWS.Range("A1").Resize(1, 24).Interior.ColorIndex = 35
    dstWS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    
    dstWS.Range("A1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With
    Application.ScreenUpdating = True
End Sub

http://office.microsoft.com/ja-jp/access/HA012290181041.aspx

id:yuk1nko

マクロを修正したところ、無事、データ処理、出来ました。

大変、助かりました。

地道に作業したら、ミスはするだろうし、時間もかかるし、

途方にくれていたところでした。

本当に、ありがとうございました。

2010/02/26 00:42:10

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912010/02/25 02:49:50

ポイント100pt

この回答では期待通りの結果にならないと思いますので、コメントを有効にしてください。

質問に書かれた表からは、正確なデータの配置が把握できなかったので、下記を想定した例です。

動作条件:

  • すべてのファイルの先頭シートに同じ書式でデータがある。
  • A2にデータ年、C2にデータ月、データはA3から32×25(実データはB4から31×24)にある。
  • 表にセル結合は使用していない

上記の条件であれば、先頭で指定したフォルダ下にあるファイルをすべて統合するようにしています。


 Sub MakeDataBook()
    Const filePath = "D:\DataFiles"  '★  実際のパスに修正
    Const yearCell = "A2"  '★  年のデータセル
    Const monthCell = "C2" '★  月のデータセル
 
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Application.ScreenUpdating = False
    Dim dstWS As Worksheet
    Set dstWS = Workbooks.Add().Worksheets(1)

    Dim wsNum As Long
    Dim xlFile As Object
    
    For Each xlFile In fso.GetFolder(filePath).Files
        If LCase(fso.GetExtensionName(xlFile.Path)) = "xls" Then
            With Workbooks.Open(xlFile.Path)
                With .Worksheets(1)
                    .Range("B3").Resize(30, 40).Copy
                     dstWS.Range("A1").Offset(40 * wsNum, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                     For i = 40 * wsNum + 1 To 40 * wsNum + 35
                         If dstWS.Cells(i, "A") <> "" Then
                             dstWS.Cells(i, "A") = DateSerial(.Range(yearCell), .Range(monthCell), dstWS.Cells(i, "A"))
                         End If
                     Next
                     wsNum = wsNum + 1
                End With
                .Close
            End With
        End If
    Next
 
 ' 表の整形
    dstWS.Range("A1").Resize(1, 40).EntireColumn.Sort Key1:=dstWS.Range("A1")
    dstWS.Rows(1).Insert
    dstWS.Range("A1").Resize(1, 24) = Array("", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24")
    dstWS.Range("A1").Resize(1, 24).Interior.ColorIndex = 35
    dstWS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    
    dstWS.Range("A1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With
    Application.ScreenUpdating = True
End Sub

マクロでうまくいかない部分があったらコメントください。

http://allabout.co.jp/gm/gl/472/

id:yuk1nko

回答ありがとうございます。

1つ質問です。

動作条件のデータ年月についてですが、

・A2にデータ年、C2にデータ月、データはA3から32×25(実データはB4から31×24)にある。

→B3にデータ年月が入っています。

 ●年●月のような形式で入っており、文字列扱いになります。

 これだと、データの形式が違ってしまって、途中で、マクロがとまってしまいます。

 対処法を教えて頂けたらと思います。

初歩的な質問で申し訳ありませんが、

よろしくお願い致します。

2010/02/25 12:45:47
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912010/02/25 15:24:41ここでベストアンサー

ポイント100pt

コメントが無効ですので、回答で失礼します。(コメントを有効にお願いします。)

下記の2か所を変更してみてください。

Sub MakeDataBook()
    Const filePath = "D:\DataFiles"  '★  実際のパスに修正
    Const DateCell = "B2"  '★  年月のデータセル :★★修正
 
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Application.ScreenUpdating = False
    Dim dstWS As Worksheet
    Set dstWS = Workbooks.Add().Worksheets(1)

    Dim wsNum As Long
    Dim xlFile As Object
    
    For Each xlFile In fso.GetFolder(filePath).Files
        If LCase(fso.GetExtensionName(xlFile.Path)) = "xls" Then
            With Workbooks.Open(xlFile.Path)
                With .Worksheets(1)
                    .Range("B3").Resize(30, 40).Copy
                     dstWS.Range("A1").Offset(40 * wsNum, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                     For i = 40 * wsNum + 1 To 40 * wsNum + 35
                         If dstWS.Cells(i, "A") <> "" Then
                             dstWS.Cells(i, "A") = CDate(.Range(DateCell) & dstWS.Cells(i, "A") & "日") ' ★★修正
                         End If
                     Next
                     wsNum = wsNum + 1
                End With
                .Close
            End With
        End If
    Next
 
 ' 表の整形
    dstWS.Range("A1").Resize(1, 40).EntireColumn.Sort Key1:=dstWS.Range("A1")
    dstWS.Rows(1).Insert
    dstWS.Range("A1").Resize(1, 24) = Array("", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24")
    dstWS.Range("A1").Resize(1, 24).Interior.ColorIndex = 35
    dstWS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    
    dstWS.Range("A1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With
    Application.ScreenUpdating = True
End Sub

http://office.microsoft.com/ja-jp/access/HA012290181041.aspx

id:yuk1nko

マクロを修正したところ、無事、データ処理、出来ました。

大変、助かりました。

地道に作業したら、ミスはするだろうし、時間もかかるし、

途方にくれていたところでした。

本当に、ありがとうございました。

2010/02/26 00:42:10

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

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

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

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

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