[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『時分毎に集約する方法』(テルーザ)
お世話になります。
各部署から送られてくる日報を、時間が早い順に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 >
マクロの記録でも出来そうですが、たたき台だけ造ったので・・・ 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
どこで発生しているか分かりません。 再現出来る手順を教えてください。 というか一度は出来たのでは?
『マクロを「書いてみた」「動かした」「ダメでした」。』
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
中の Range も .Range にして直らないですか。 (Mook) 2014/08/23(土) 23:19
いやそうじゃなくて…。 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
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
(テルーザ) 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
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.