Excel VBA 質問スレッド №1973 (解決済)

条件付き複数シートを集計したい！

投稿者 : Mow     投稿日時 : 2024/07/25(Thu) 11:43:45     OS : Mac OS X     EXCEL : Excel 2016
下記条件でamountシートへ集計したいです。
For i などは試したのですが、起動せず、、、
どなたか教えていただけますでしょうか。
よろしくお願いいたします。 

Sub 集計()
   Sheets("amount").Cells.Clear
   Dim Date1, i
    Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例24/ 7 /3")
  
   
    Sheets("S").Range("A2").AutoFilter field:=5, Criteria1:=Date1
    Sheets("S").Range("A1").CurrentRegion.Copy Sheets("amount").Range("A2")
    
    Sheets("S").AutoFilterMode = False
    Next
    
    Application.ScreenUpdating = True
    Sheets("amount").Select
    
   End Sub

スポンサーリンク
[返信 1] Re : 条件付き複数シートを集計したい！
投稿者 : さんこう     投稿日時 : 2024/07/25(Thu) 11:52:11
＞条件付き複数シートを集計したい！

「複数シート」とは何でしょうか？


＞下記条件でamountシートへ集計したい

「下記条件」とは何でしょうか？

「集計」とは、具体的にどうするのでしょうか？

[返信 2] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/25(Thu) 12:42:11
■[返信 1] さんこうさん（2024-07-25 11:52:11）の記事
＞ ＞条件付き複数シートを集計したい！
＞
＞ 「複数シート」とは何でしょうか？
＞
＞
＞ ＞下記条件でamountシートへ集計したい
＞
＞ 「下記条件」とは何でしょうか？
＞
＞ 「集計」とは、具体的にどうするのでしょうか？
＞

ご連絡いただきありがとうございます。
現在、下記コードを書いております。
今回の目的としては、例えばamountシート内にボタンを設置し、24/7/2と日付を入力すると、1つのブック内にある複数のシート（例えば、シート1・シート2....）から自動でフィルターをかけ、対象となる日程の列をamountシートへ移行したいと考えております。

また、各シートの列は日々増えていきます。


>Sub 集計()
> Sheets("amount").Cells.Clear
> Dim Date1
> Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例24/ 7 /3")

> Sheets("S").Range("A1").AutoFilter field:=5, Criteria1:=Date1
> Sheets("S").Range("A1").CurrentRegion.Copy Sheets("amount").Range("A2")

> Sheets("S").AutoFilterMode = False

> Application.ScreenUpdating = True
> Sheets("amount").Select

> End Sub

[返信 3] Re : 条件付き複数シートを集計したい！
投稿者 : さんこう     投稿日時 : 2024/07/25(Thu) 12:57:42
列が増えていくとかが謎ですが、とりあえずフィルターなしで
シートをまとめるところから作っていくとよろしいかと思います。


＜vba シート 集約＞
https://www.google.com/search?q=vba+%E3%82%B7%E3%83%BC%E3%83%88+%E9%9B%86%E7%B4%84

[返信 4] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/25(Thu) 13:15:49
■[返信 3] さんこうさん（2024-07-25 12:57:42）の記事
＞ 列が増えていくとかが謎ですが、とりあえずフィルターなしで
＞ シートをまとめるところから作っていくとよろしいかと思います。
＞
＞
＞ ＜vba シート 集約＞
＞ https://www.google.com/search?q=vba+%E3%82%B7%E3%83%BC%E3%83%88+%E9%9B%86%E7%B4%84

ご教授ありがとうございます。

シートまとめは、下記コードでできました！
昨日からVBAを始めたばかりで、無知すぎるのでさらにご教授いただきたいです。

下記コードに例えば日次(24/7/2)が該当するデータのみを引っ張るようにするにはどうしたらいいでしょうか？
よろしくお願いいたします。

Sub matome()
　Dim i As Integer
　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Application.ScreenUpdating = False
　 　'----全データシートの有無をチェックします
　　sh_check
　　'----列見出しをコピーします
　　Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　　　'----シートのデータが2行以上の場合にコピーします
　　　　　　If lRow >= 2 Then
　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　　　.Activate
　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
　　　　　　End If
　　　　End With
　　Next i
　　Worksheets(1).Activate
　　Range("A1").Select
　　Application.ScreenUpdating = True
End Sub

[返信 5] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/25(Thu) 13:16:26
ご教授ありがとうございます。

シートまとめは、下記コードでできました！
昨日からVBAを始めたばかりで、無知すぎるのでさらにご教授いただきたいです。

下記コードに例えば日次(24/7/2)が該当するデータのみを引っ張るようにするにはどうしたらいいでしょうか？
よろしくお願いいたします。

Sub matome()
　Dim i As Integer
　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Application.ScreenUpdating = False
　 　'----全データシートの有無をチェックします
　　sh_check
　　'----列見出しをコピーします
　　Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　　　'----シートのデータが2行以上の場合にコピーします
　　　　　　If lRow >= 2 Then
　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　　　.Activate
　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
　　　　　　End If
　　　　End With
　　Next i
　　Worksheets(1).Activate
　　Range("A1").Select
　　Application.ScreenUpdating = True
End Sub

[返信 6] Re : 条件付き複数シートを集計したい！
投稿者 : さんこう     投稿日時 : 2024/07/25(Thu) 14:10:03
＞下記コードに例えば日次(24/7/2)が該当するデータのみを引っ張るようにするにはどうしたらいいでしょうか？


最初にご提示のあったコードにある、フィルターするところを組み合わせればよろしいかと思います。


↓イメージですので、動くかわかりませんが、こんな感じでしょうか。

　　　　　　'----シートのデータが2行以上の場合にコピーします
　　　　　　If lRow >= 2 Then
　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　　　.Activate

　　　　　　　　’ここでフィルターをかける
　　　　　　 .Range("A2").AutoFilter field:=5, Criteria1:=Date1

　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)

[返信 7] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/25(Thu) 14:25:35
■[返信 6] さんこうさん（2024-07-25 14:10:03）の記事
＞ ＞下記コードに例えば日次(24/7/2)が該当するデータのみを引っ張るようにするにはどうしたらいいでしょうか？
＞
＞
＞ 最初にご提示のあったコードにある、フィルターするところを組み合わせればよろしいかと思います。
＞
＞
＞ ↓イメージですので、動くかわかりませんが、こんな感じでしょうか。
＞
＞ 　　　　　　'----シートのデータが2行以上の場合にコピーします
＞ 　　　　　　If lRow >= 2 Then
＞ 　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
＞ 　　　　　　　　.Activate
＞
＞ 　　　　　　　　’ここでフィルターをかける
＞ 　　　　　　 .Range("A2").AutoFilter field:=5, Criteria1:=Date1
＞
＞ 　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
＞
＞
＞ ご教授ありがとうございます！

.Range("A2").AutoFilter field:=5, Criteria1:=Date1

こちらの部分で実行時エラー '1004　rangeクラスのautofilterメソッドが失敗しました　と表示されてしまいました,,,

解決策はありますでしょうか？
よろしくお願いいたします。

[返信 8] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/25(Thu) 14:27:01
現状のコードは下記のとおりです。

Sub matome()
  Dim i As Integer
  Dim lRow As Long, lCol As Long, lRow2 As Long
    Application.ScreenUpdating = False
     Dim Date1
    Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例24/ 7 /3")
    '----列見出しをコピーします
    Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
    For i = 2 To Worksheets.Count
        With Worksheets(i)
            lRow = .Cells(Rows.Count, 1).End(xlUp).Row
            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            '----シートのデータが2行以上の場合にコピーします
            If lRow >= 2 Then
                lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Activate
                
                 .Range("A2").AutoFilter field:=5, Criteria1:=Date1

                .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
            End If
        End With
    Next i
    Worksheets(1).Activate
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

[返信 9] Re : 条件付き複数シートを集計したい！
投稿者 : さんこう     投稿日時 : 2024/07/25(Thu) 15:03:42
＞こちらの部分で実行時エラー '1004　rangeクラスのautofilterメソッドが失敗しました　と表示されてしまいました,,,

シートの状態にも影響されるはずなので、なんともいえませんが、
オートフィルターを解除するようにしてみたらいかがでしょうか。


Sub matome()
    Dim i As Long
    Dim lRow As Long, lCol As Long, lRow2 As Long
    Application.ScreenUpdating = False
    Dim Date1
    Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例24/ 7 /3")
    '----列見出しをコピーします
    Worksheets(1).Cells.ClearContents
    Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
    For i = 2 To Worksheets.Count
        With Worksheets(i)
            If .AutoFilter Is Nothing Then .AutoFilterMode = False                          '★
            lRow = .Cells(Rows.Count, 1).End(xlUp).Row
            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            '----シートのデータが2行以上の場合にコピーします
            If lRow >= 2 Then
                lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Activate
                
                .Range("A1").AutoFilter field:=5, Criteria1:=Date1

                .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
                .AutoFilterMode = False                                                     '★
            End If
        End With
    Next i
    Worksheets(1).Activate
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

[返信 10] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/25(Thu) 15:39:47
■[返信 9] さんこうさん（2024-07-25 15:03:42）の記事
＞ ＞こちらの部分で実行時エラー '1004　rangeクラスのautofilterメソッドが失敗しました　と表示されてしまいました,,,
＞
＞ シートの状態にも影響されるはずなので、なんともいえませんが、
＞ オートフィルターを解除するようにしてみたらいかがでしょうか。
＞
＞
＞ Sub matome()
＞ Dim i As Long
＞ Dim lRow As Long, lCol As Long, lRow2 As Long
＞ Application.ScreenUpdating = False
＞ Dim Date1
＞ Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例24/ 7 /3")
＞ '----列見出しをコピーします
＞ Worksheets(1).Cells.ClearContents
＞ Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
＞ For i = 2 To Worksheets.Count
＞ With Worksheets(i)
＞ If .AutoFilter Is Nothing Then .AutoFilterMode = False '★
＞ lRow = .Cells(Rows.Count, 1).End(xlUp).Row
＞ lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
＞ '----シートのデータが2行以上の場合にコピーします
＞ If lRow >= 2 Then
＞ lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
＞ .Activate
＞
＞ .Range("A1").AutoFilter field:=5, Criteria1:=Date1
＞
＞ .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
＞ .AutoFilterMode = False '★
＞ End If
＞ End With
＞ Next i
＞ Worksheets(1).Activate
＞ Range("A1").Select
＞ Application.ScreenUpdating = True
＞ End Sub
＞

ご教授いただきありがとうございます。
ご教授いただいた内容で、作動できましたが全てのデータが出力されてしまいました,,,,

field:=5, Criteria1:=Date1

を適応させるための方法をお教えください。
よろしくお願いいたします。

[返信 11] Re : 条件付き複数シートを集計したい！
投稿者 : さんこう     投稿日時 : 2024/07/25(Thu) 15:51:42
＞全てのデータが出力されてしまいました

日付の場合はややこしいです。

参考になれば。

＜vba オートフィルタ 日付＞
https://www.google.com/search?q=vba+%E3%82%AA%E3%83%BC%E3%83%88%E3%83%95%E3%82%A3%E3%83%AB%E3%82%BF+%E6%97%A5%E4%BB%98

[返信 12] Re : 条件付き複数シートを集計したい！
投稿者 : mow     投稿日時 : 2024/07/26(Fri) 09:44:27
■[返信 11] さんこうさん（2024-07-25 15:51:42）の記事
＞ ＞全てのデータが出力されてしまいました
＞
＞ 日付の場合はややこしいです。
＞
＞ 参考になれば。
＞
＞ ＜vba オートフィルタ 日付＞
＞ https://www.google.com/search?q=vba+%E3%82%AA%E3%83%BC%E3%83%88%E3%83%95%E3%82%A3%E3%83%AB%E3%82%BF+%E6%97%A5%E4%BB%98
＞ 

Option Explicit
Sub matome()
    Dim i As Long
    Dim lRow As Long, lCol As Long, lRow2 As Long
    Dim rng As Range, rng2 As Range
   Dim Date1 As String
    Dim fmt As String
    Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例 24/7/26) ")
    fmt = Worksheets(2).Range("E2").NumberFormatLocal  ' 表示形式を取得
    
    Application.ScreenUpdating = False
    Worksheets(1).Cells.ClearContents
    Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
    For i = 2 To Worksheets.Count
        With Worksheets(i)
            If .AutoFilter Is Nothing Then .AutoFilterMode = False    '★
            lRow = .Cells(Rows.Count, 1).End(xlUp).Row
            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            Set rng = .Range(.Cells(1, 1), .Cells(lRow, lCol))
            Set rng2 = .Range(.Cells(2, 1), .Cells(lRow, lCol))
            If lRow >= 2 Then
                lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
                rng.AutoFilter field:=5, Criteria1:=Format(DateValue(Date1), fmt)
                If Intersect(rng, .Columns("A")).SpecialCells(xlCellTypeVisible) _
                   .Count >= 2 Then
                    rng2.Copy Worksheets(1).Cells(lRow2, 1)
                End If
                .AutoFilterMode = False
            End If
        End With
    Next i
    Worksheets(1).Activate
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

できました！ご教授いただきありがとうございました！！！

当掲示板について
  • Excel VBA に関する掲示板です。Excel VBA に関する質問や疑問、それに対する解決方法など気軽に投稿してください。
  • 記事内ではHTMLのタグは使用できません。
  • 記事は一度投稿すると修正できません。内容を訂正したい場合は返信で対応してください。
  • Sub〜End Sub、Function〜End Function は自動的にプログラムコードとみなし、枠で囲って見やすくします。
  • Excel VBA とは関係ないことや、他人が不快に思うようなことなど、管理人が適当でないと判断した記事は削除する場合があります。
スポンサーリンク
返信入力フォーム
お　名　前　　：
内　　容　　　：

ステータス　　：

認証コード　　： キャプチャ画像 




( 処理日時 : 2025-07-03 17:33:32 )
タイトルとURLをコピーしました