[[20140816151353]] 『時分毎に集約する方法』(テルーザ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『時分毎に集約する方法』(テルーザ)

お世話になります。
各部署から送られてくる日報を、時間が早い順に1シートに集約し時系列表を作成する方法を教えてください。

Book1-Sheet1
 A1     B1       C1

 9:00      A舎でトラブル  けが人なし

Book2-Sheet1
 A1     B1       C1

 8:45      B舎でトラブル  けが人あり

Book3-Sheet1
 A1     B1       C1

 10:00      C舎でトラブル  けが人なし

別Book-Sheet1 
 A1     B1       C1
8:45 B舎でトラブル  けが人あり
9:00 A舎でトラブル  けが人なし
10:00 C舎でトラブル  けが人なし

< 使用 Excel:Excel2010、使用 OS:WindowsXP >


各日報データを1枚のシートに取り込んでから、データ範囲をすべて選択して、
[データ]ー[並べ替え]でA列(時刻)を昇順に並べ替えを行えば、
時間の早い順に時系列表が作成される
(wisemac21) 2014/08/18(月) 09:16

 マクロの記録でも出来そうですが、たたき台だけ造ったので・・・
    Sub テルーザ()
        Dim WB As Collection
        Set WB = New Collection

        '//実際に転記したいファイルをフルパスで入力してください。
        ' 追加は「WB.Add "ファイル名"」をコピーして増やしてください
        WB.Add "C:\エクセルの学校\テルーザ\Book1.xlsm"
        WB.Add "C:\エクセルの学校\テルーザ\Book2.xlsm"
        WB.Add "C:\エクセルの学校\テルーザ\Book3.xlsm"

        Dim mySH As Worksheet

        '//転記先のシート名(初期設定はコードが書いてあるブックのSheet1)を入力してください
        ' フルパスは指定できません。
        Set mySH = ThisWorkbook.Sheets("Sheet1")
        mySH.Cells.ClearContents
        Dim c
        Dim objWB As Workbook
        Dim tbl
        For Each c In WB
            Set objWB = WB_Open(c)
            If Not objWB Is Nothing Then
                With objWB
                    With .Sheets("Sheet1")
                        '        ~~~~~~~~
                        '//転記元のシート名と列範囲を指定してください。
                        ' デフォルトはSheet1のA〜C列です。
                        tbl = .Range("C1", Range("A" & .Rows.Count).End(xlUp)).Value
                        '            ~~~~
                    End With
                    .Close savechanges:=False
                End With
            End If
            If tbl(1, 1) <> "" Then
                mySH.Range("A" & mySH.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End If
        Next c
        With mySH
            .Rows("1:1").Delete shift:=xlUp
            With .Sort
                With .SortFields
                    .Clear
                    .Add Key:=mySH.Range("A1"), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortTextAsNumbers
                End With
                .SetRange mySH.Range("A1").CurrentRegion
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
    End Sub
    Function WB_Open(ByVal WBN As String) As Workbook
        Dim WB As String
        WB = Dir(WBN)
        If WB <> "" Then
            On Error Resume Next
            Set WB_Open = Workbooks(WB)
            If Err > 0 Then Workbooks.Open WBN, ReadOnly:=True
            On Error GoTo 0
            Set WB_Open = Workbooks(WB)
        Else
            Set WB_Open = Nothing
        End If
    End Function

(稲葉) 2014/08/18(月) 09:26


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

(テルーザ) 2014/08/19(火) 22:39


「functionまたは変数が必要です」というエラーがでます。
どうしたらよろしいでしょうか?
(テルーザ) 2014/08/21(木) 22:46

 どこで発生しているか分かりません。
 再現出来る手順を教えてください。
 というか一度は出来たのでは?

『マクロを「書いてみた」「動かした」「ダメでした」。』
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_200.html
『デバッグトレースの開始方法』
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html

(稲葉) 2014/08/22(金) 08:33


お世話になります。

実行時エラー1004
「アプリケーション定義または、オブジェクト定義のエラーです。」
と出てしまいます。
ビギナー内容ですみません。
よろしくお願いいたします。

        WB.Add "C:\Users\***\Desktop\新しいフォルダー\Book1.xlsm"
        WB.Add "C:\Users\***\Desktop\新しいフォルダー\Book2.xlsm"
        WB.Add "C:\Users\***\Desktop\新しいフォルダー\Book3.xlsm"

        Dim mySH As Worksheet

        '//転記先のシート名(初期設定はコードが書いてあるブックのSheet1)を入力してください
        ' フルパスは指定できません。
        Set mySH = ThisWorkbook.Sheets("Sheet1")
        mySH.Cells.ClearContents
        Dim c
        Dim objWB As Workbook
        Dim tbl
        For Each c In WB
            Set objWB = WB_Open(c)
            If Not objWB Is Nothing Then
                With objWB
                    With .Sheets("Sheet1")
                        '        ~~~~~~~~
                        '//転記元のシート名と列範囲を指定してください。
                        ' デフォルトはSheet1のA〜C列です。
                        tbl = .Range("C1", Range("A" & .Rows.Count).End(xlUp)).Value
                        '            ~~~~
                    End With
                    .Close savechanges:=False
                End With
            End If
            If tbl(1, 1) <> "" Then
                mySH.Range("A" & mySH.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End If
        Next c
        With mySH
            .Rows("1:1").Delete shift:=xlUp
            With .Sort
                With .SortFields
                    .Clear
                    .Add Key:=mySH.Range("A1"), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortTextAsNumbers
                End With
                .SetRange mySH.Range("A1").CurrentRegion
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
    End Sub
    Function WB_Open(ByVal WBN As String) As Workbook
        Dim WB As String
        WB = Dir(WBN)
        If WB <> "" Then
            On Error Resume Next
            Set WB_Open = Workbooks(WB)
            If Err > 0 Then Workbooks.Open WBN, ReadOnly:=True
            On Error GoTo 0
            Set WB_Open = Workbooks(WB)
        Else
            Set WB_Open = Nothing
        End If
    End Function

(テルーザ) 2014/08/23(土) 01:06


 >実行時エラー1004 
 >「アプリケーション定義または、オブジェクト定義のエラーです。」
 >と出てしまいます。 

 どこの部分でエラーが出るのでしょう?

 ※稲葉さんのリンク先は見られましたか?
(カリーニン) 2014/08/23(土) 01:27

お世話になります。
「tbl = .Range("C1", Range("A" & .Rows.Count).End(xlUp)).Value」
アプリケーション、オブジェクト定義エラーと表示されます。
すみません。よろしくお願いいたします。
(テルーザ) 2014/08/23(土) 23:10

 中の Range も .Range にして直らないですか。
(Mook) 2014/08/23(土) 23:19

お世話になります。
「,Range」から「.Range」にしましたが「区切り記号または」とエラー表示されました。
また「Book1」のデータしか飛んで来ないのも何か原因があるのでしょうか?
よろしくお願いいたします。
(テルーザ) 2014/08/23(土) 23:54

 いやそうじゃなくて…。
   tbl = .Range("C1", Range("A" & .Rows.Count).End(xlUp)).Value
            ↓
   tbl = .Range("C1", .Range("A" & .Rows.Count).End(xlUp)).Value
(Mook) 2014/08/24(日) 07:54

お世話になります。
「.Range」につきましては、無事に解決いたしました。
ありがとうございました。
質問ばかりで申し訳ありません。
今度は、拡張子が「xls」のExcelで実行すると「With .Sort」が青、「Private Sub CommandButton1_Click()」黄色になり、「メソッドまたはデータ メンバが見つかりません」とエラー表示されます。
古いExcelでは使用できないのでしょうか?
よろしくお願いいたします。
(テルーザ) 2014/08/25(月) 00:09

 Mookさんフォローありがとうございます。
 .よく忘れてすみません・・・

 テルーザさん
 Sortオブジェクトは2007からの仕様です。
 どちらでも出来るように分岐させました。

 こちらでお試しください。
    Sub テルーザ()
        Dim WB As Collection
        Set WB = New Collection

        '//実際に転記したいファイルをフルパスで入力してください。
        ' 追加は「WB.Add "ファイル名"」をコピーして増やしてください
        WB.Add "C:\エクセルの学校\テルーザ\Book1.xlsm"
        WB.Add "C:\エクセルの学校\テルーザ\Book2.xlsm"
        WB.Add "C:\エクセルの学校\テルーザ\Book3.xlsm"

        Dim mySH As Worksheet

        '//転記先のシート名(初期設定はコードが書いてあるブックのSheet1)を入力してください
        ' フルパスは指定できません。
        Set mySH = ThisWorkbook.Sheets("Sheet1")
        mySH.Cells.ClearContents
        Dim c
        Dim objWB As Workbook
        Dim tbl
        For Each c In WB
            Set objWB = WB_Open(c)
            If Not objWB Is Nothing Then
                With objWB
                    With .Sheets("Sheet1")
                        '        ~~~~~~~~
                        '//転記元のシート名と列範囲を指定してください。
                        ' デフォルトはSheet1のA〜C列です。
                        tbl = .Range("C1", .Range("A" & .Rows.Count).End(xlUp)).Value
                        '            ~~~~
                    End With
                    .Close savechanges:=False
                End With
            End If
            If tbl(1, 1) <> "" Then
                mySH.Range("A" & mySH.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End If
        Next c
        With mySH
            .Rows("1:1").Delete shift:=xlUp
            Select Case CInt(Application.Version)
                Case Is <= 11
                    mySH.Range("A1").CurrentRegion.Sort Key1:=mySH.Range("A1"), _
                        Order1:=xlAscending, _
                        Header:=xlNo
                Case Is >= 12
                    With .Sort
                        With .SortFields
                            .Clear
                            .Add Key:=mySH.Range("A1"), _
                                SortOn:=xlSortOnValues, _
                                Order:=xlAscending, _
                                DataOption:=xlSortTextAsNumbers
                        End With
                        .SetRange mySH.Range("A1").CurrentRegion
                        .Header = xlNo
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
            End Select
        End With
    End Sub
 17:34Sortメソッドで範囲を正しく設定出来ていなかったので修正

 (稲葉) 2014/08/25(月) 08:59

お世話になります。
今度は、WB Open(c) が青くなり、 subまたは、functionが定義されていません。
とエラーが表示されます。
度々すみませんが、ご対応よろしくお願いいたします。

(テルーザ) 2014/08/25(月) 13:23


 Functionは置き換えなくていいです。
    Function WB_Open(ByVal WBN As String) As Workbook
        Dim WB As String
        WB = Dir(WBN)
        If WB <> "" Then
            On Error Resume Next
            Set WB_Open = Workbooks(WB)
            If Err > 0 Then Workbooks.Open WBN, ReadOnly:=True
            On Error GoTo 0
            Set WB_Open = Workbooks(WB)
        Else
            Set WB_Open = Nothing
        End If
    End Function

(稲葉) 2014/08/25(月) 14:30


お世話になります。
「 Function WB_Open(ByVal WBN As String) As Workbook
        Dim WB As String
        WB = Dir(WBN)
        If WB <> "" Then
            On Error Resume Next
            Set WB_Open = Workbooks(WB)
            If Err > 0 Then Workbooks.Open WBN, ReadOnly:=True
            On Error GoTo 0
            Set WB_Open = Workbooks(WB)
        Else
            Set WB_Open = Nothing
        End If
    End Function 」
上記これらは、最下段に追記で対応すればよろしいですよね?

追記した結果、「 With .Sort 」の「 Sort」が青くなり、「メソッドまたは、メンバが見つかりません。」と表示されました。
指定した名前のスペルは確認しましたがわかりません。
他力本願ですみません。
よろしくお願いいたします。

Case Is >= 12

                    With .Sort
                        With .SortFields
                            .Clear
                            .Add Key:=mySH.Range("A1"), _
                                SortOn:=xlSortOnValues, _
                                Order:=xlAscending, _
                                DataOption:=xlSortTextAsNumbers
                        End With
(テルーザ) 2014/08/25(月) 22:19

 2003環境を持ってないので分からないのですが・・・
 Case Is >= 12
 で分岐されていることから、少なくとも開いているエクセルのバージョンは2007以降ですよね?
 With mySHで囲まれている範囲を下記に置き換えてください
        With mySH
            .Rows("1:1").Delete shift:=xlUp
            .Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
                Order1:=xlAscending, _
                Header:=xlNo
        End With

(稲葉) 2014/08/26(火) 08:37


お世話になります。稲葉 様

2003環境で実行しております。

結局、エラーは解消されませんでした。

Private Sub CommandButton1_Click()

  Dim WB As Collection
        Set WB = New Collection

        WB.Add "C:\Users\***\Desktop\災害\集計報.xls"
       Dim mySH As Worksheet

        '//転記先のシート名(初期設定はコードが書いてあるブックのSheet1)を入力してください
        ' フルパスは指定できません。
        Set mySH = ThisWorkbook.Sheets("Sheet1")
        mySH.Cells.ClearContents
        Dim c
        Dim objWB As Workbook
        Dim tbl
        For Each c In WB
            Set objWB = WB_Open(c)
            If Not objWB Is Nothing Then
                With objWB
                    With .Sheets("Sheet1")
                        '        ~~~~~~~~
                        '//転記元のシート名と列範囲を指定してください。
                        ' デフォルトはSheet1のA〜C列です。
                        tbl = .Range("C1", .Range("A" & .Rows.Count).End(xlUp)).Value
                        '            ~~~~
                    End With
                    .Close savechanges:=False
                End With
            End If
            If tbl(1, 1) <> "" Then
                mySH.Range("A" & mySH.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End If
        Next c
        With mySH
            .Rows("1:1").Delete shift:=xlUp
            .Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
                Order1:=xlAscending, _
                Header:=xlNo
        End With
                        .SetRange mySH.Range("A1").CurrentRegion
                        .Header = xlNo
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
            End Select
        End With
    End Sub
Function WB_Open(ByVal WBN As String) As Workbook
        Dim WB As String
        WB = Dir(WBN)
        If WB <> "" Then
            On Error Resume Next
            Set WB_Open = Workbooks(WB)
            If Err > 0 Then Workbooks.Open WBN, ReadOnly:=True
            On Error GoTo 0
            Set WB_Open = Workbooks(WB)
        Else
            Set WB_Open = Nothing
        End If
    End Function

拙い私に、長期お付き合いして頂きありがとうございました。
大分、背伸びをしていたようです。
ありがとうございました。

(テルーザ) 2014/08/26(火) 20:47


 理由はわかりませんが、貼り付けるまえにソートする方法もできます
 金曜日まで待っていただければ対応致します
 また、ソートだけご自身で出来るのでしたら、ソートよコードだけ抜いても宜しいのではないでしょうか?
(稲葉) 2014/08/27(水) 14:24

 というか、よく見たらコードおかしい、、、
 コンパイルエラーでませんでしたか?
 どなたかフォローお願いします、、、

(稲葉) 2014/08/27(水) 14:26


 とりあえずエラーが出ないように整えただけですが
'----------------------------------------
Private Sub CommandButton1_Click()
    Dim WB As Collection
    Set WB = New Collection
    WB.Add "C:\Users\***\Desktop\災害\集計報.xls"
    Dim mySH As Worksheet
    '//転記先のシート名(初期設定はコードが書いてあるブックのSheet1)を入力してください
    ' フルパスは指定できません。
    Set mySH = ThisWorkbook.Sheets("Sheet1")
    mySH.Cells.ClearContents
    Dim c
    Dim objWB As Workbook
    Dim tbl
    For Each c In WB
        Set objWB = WB_Open(c)
        If Not objWB Is Nothing Then
            With objWB
                With .Sheets("Sheet1")
                    '        ~~~~~~~~
                    '//転記元のシート名と列範囲を指定してください。
                    ' デフォルトはSheet1のA〜C列です。
                    tbl = .Range("C1", .Range("A" & .Rows.Count).End(xlUp)).Value
                    '            ~~~~
                End With
                .Close savechanges:=False
            End With
        End If
        If tbl(1, 1) <> "" Then
            mySH.Range("A" & mySH.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
        End If
    Next c
    With mySH
        .Rows("1:1").Delete shift:=xlUp
        .Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
            Order1:=xlAscending, _
            Header:=xlNo
    End With
End Sub
Function WB_Open(ByVal WBN As String) As Workbook
    Dim WB As String
    WB = Dir(WBN)
    If WB <> "" Then
        On Error Resume Next
        Set WB_Open = Workbooks(WB)
        If Err > 0 Then Workbooks.Open WBN, ReadOnly:=True
        On Error GoTo 0
        Set WB_Open = Workbooks(WB)
    Else
        Set WB_Open = Nothing
    End If
End Function
'----------------------------------------

 To稲葉さん
質問者さんと言うよりは稲葉さんあてコメントですが
バージョンチェックを入れたコードでエラーが出たのは、
たとえSelect Caseで分岐してロジック上通らなくしていても、
「.Sort」がその環境下で使用可能か評価されてしまうからです。きっと。
    Dim mySH As Worksheet
   ↓
    Dim mySH As Object
等としてあげれば、バージョン依存のメソッドなりを織り交ぜたものも
記述可能になると思います。
(ご近所PG) 2014/08/27(水) 14:52

 プロシージャを別にすれば、VBAProjectのコンパイルではエラーになりますが、
 実行は出来ます。
Private Sub CommandButton1_Click()
    Dim mySH As Worksheet
    Set mySH = ThisWorkbook.Sheets("Sheet1")
    Select Case CInt(Application.Version)
        Case Is <= 11
            Sort2003 mySH
        Case Is >= 12
            Sort2007 mySH
    End Select
End Sub
Sub Sort2003(mySH As Worksheet)
    mySH.Range("A1").CurrentRegion.Sort Key1:=mySH.Range("A1"), _
        Order1:=xlAscending, _
        Header:=xlNo
End Sub
Sub Sort2007(mySH As Worksheet)
    With mySH.Sort
        With .SortFields
            .Clear
            .Add Key:=mySH.Range("A1"), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortTextAsNumbers
        End With
        .SetRange mySH.Range("A1").CurrentRegion
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
(cai) 2014/08/27(水) 16:52

 ご近所PGさん、caiさんありがとうございます
 実行時じゃなくて、コンパイル時にエラーが出ていたんですね

 #IFで、コンパイル時にバージョン分岐させないと、もとから
 実行できなかったんですね、、、

 知識不足ですみませんでした
(稲葉) 2014/08/27(水) 17:18

お世話になります。お礼が遅くなりまして、大変失礼致しました。
サイト全体にご迷惑を御掛けしてたようで…。
今後、一切の利用を控えることで勘弁して頂きたいと思います。
ありがとうございました。
(テルーザ) 2014/10/15(水) 17:53

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.