スキルアップ・問題解決なら、モーグにおまかせ！

こんにちは！
昨日VBAを始めました。
上司からエクセルの強要があったので、できるだけ楽をするためにVBAを学び始めました,,,😭
 
 
現在、やりたいこと
1つのブックに複数シートがあり、それぞれは同じフォーマットで記入されています。（品番・タイトル・日付...）これらのシートの中で例えば、24/7/2に売れた商品のみを集計し、集計シートで一覧が見れるようにしたいです。
 
現状、
全てのデータを集計シートへ移行するコードまではできているはずです,,
 
上記のやりたいことを達成できるVBAコードを教えていただきたいです。
よろしくお願いいたします。
 
 
Sub matome()
　Dim i As Integer
　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Application.ScreenUpdating = False
　
　　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
　　　　
　　　　　　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
 
 

VBA二日目ですか。すごい長足の進歩ですね。
 
特定の日付のデータだけを抽出するのであれば、
まずはオートフィルタの利用をトライされたらどうでしょうか。
回答をすぐに書くわけにもいかないので、まずはそちらでトライしてみてください。
（該当データがないエッジケースでうまくいかず、特別対応が必要になりますが、
  それは次のステップとして、まずは本番データとは別のものでトライしてみてはいかがですか）
 
なお、現在のコードですが、途中でActivateを使っていますが、

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

ご教授いただきありがとうございます。
autofilterを使ってみましたが、フィルターが作動せず、全てのデータが出力されてしまします,,
指定した日付のみのデータが集計されるようにするにはどうしたらいいでしょうか。
 
ご教授のほどお願いいたします。
 
現状のコードは下記のとおりです。
 
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

該当データが無いときに、今のままだと全データがコピーされる仕様です。

    .Range("A1").AutoFilter field:=5, Criteria1:=Date1
    If .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Rows.Count >= 2 Then
        .Range(.Cells(2, 1), .Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
    End If

日付指定は 2024/7/25 の形式が良いと思います。
実例で試してうまくいくかステップ実行して確認して下さい。
CDate関数で日付型に変換する最終手段がありますが、それをしなくてもうまくいきませんか？

24/07/25 17:49:40のコードは間違っていました。失礼しました。
 
以下に訂正します。

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
    
    Application.ScreenUpdating = False
    Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例2024/7/26) ")
    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:=Date1
                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

Autofilterでの日付の扱いは、Excelのversionによっても変動があり、微妙な話のようです。
以下のようにすると間違いないようです。
（ワークシートの日付の表示形式が統一されていることが前提です。)
 
【コードの変更部分】

    Dim Date1 As String
    Dim fmt As String
    Date1 = InputBox(prompt:=" 検索したい日付を書いてください。（例 24/7/26) ")
    fmt = Worksheets(2).Range("E2").NumberFormatLocal  ' 表示形式を取得

    rng.AutoFilter field:=5, Criteria1:=Format(DateValue(Date1), fmt)

ご教授いただきありがとうございます！
できました！！
 
追加でお伺いしたいんですが、特定の複数シートのみこのVBAを適応するためのコードはありますか？
ご教授いただけますと幸いです。
よろしくお願いいたします。

必要なものをコピペするという考え方もありますが、
とりあえず表をまとめてから、不要なものを消しても結果は同じかなという思想で、
考えてみました。。。
 

Option Explicit

Sub test()
    Dim wsh As Worksheet
    Dim wshResults As Worksheet
    Dim i As Long, ixRow As Long
    Dim Rng As Range
    Dim myDate As Variant
    
    Set wshResults = Worksheets(1)
    wshResults.UsedRange.ClearContents
    ixRow = 3
    '各データシートに対してコピペを繰り返し1つのシートに集約
    For i = 2 To Worksheets.Count
        'データセル範囲取得
        Set wsh = Worksheets(i)
        With wsh.Range("A1").CurrentRegion
            Set Rng = Intersect(.Cells, .Offset(1))
        End With
        'タイトル行のコピー
        If i = 2 Then
            Rng.Rows(0).Copy wshResults.Cells(ixRow, 1)
        End If
        'データのコピー
        Rng.Copy wshResults.Cells(ixRow, 1)
        '次のコピーの行番号
        ixRow = ixRow + Rng.Rows.Count
    Next
    
    '日付の指定
    Do
        myDate = InputBox("日付を入力（例2024/7/26)")
        If myDate = False Then Exit Sub
    Loop Until IsDate(myDate) = True
    myDate = CDate(myDate)
    
    '不要データを抽出してクリア
    With wshResults.Cells(1).CurrentRegion
        .AutoFilter 5, ">" & myDate, xlOr, "<" & myDate
        If .Columns(1).SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
            .Offset(1).ClearContents
            .Sort key1:=.Cells(1, 5), Header:=xlYes     '並び替えて空白を詰める
        End If
        .AutoFilter
    End With
End Sub

ご教授いただきありがとうございます！
 
今回、1つのブック内に先ほど私がお送りしたコードが適応されないシートが出てきました,,,
その適応されないシートを一旦取り除くと作動したので、コード内で作動させないようにしているシートを排除してからコード適応をしたいと考えていました。
 
的確にお伝えできず、大変申し訳ございません。
上記の経緯をもとにご教授いただけますと幸いです。
よろしくお願いいたいます。

引用:
今回、1つのブック内に先ほど私がお送りしたコードが適応されないシートが出てきました,,,
その適応されないシートを一旦取り除くと作動したので、コード内で作動させないようにしているシートを排除してからコード適応をしたいと考えていました。

    With Worksheets(i)
        If .Name <> "Sheet1" Then
            ' (中略)
        End If
    End With

simple さんの引用:

引用:
今回、1つのブック内に先ほど私がお送りしたコードが適応されないシートが出てきました,,,
その適応されないシートを一旦取り除くと作動したので、コード内で作動させないようにしているシートを排除してからコード適応をしたいと考えていました。

エラーか何かになるのですか？それを検証して改善する必要は無いのですか？
ともかく動きさえすればよく、抽出漏れがあっても構わない、ということであれば、

    With Worksheets(i)
        If .Name <> "Sheet1" Then
            ' (中略)
        End If
    End With

エラーになった状態のときに、
イミディエイトウインドウに

?rng.Address

ご連絡ありがとうございます。
?rng.Address
$A$1:$A$3
上記の内容の返答がきました。
どこかのシートでA1.A3が対応されていないということでしょうか？

エラーになったシートの見出し行が一行目ではないのでは？
 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
が1になっているのでは？
  
エラーになたi番目のシートは他と違って、もともとデータシートではないのでは？
あなたしか見えないものなので、そちらで解決して下さい。

ご教授いただいたとおり、データシートではございません。
エラーシートを無視した状態で他のシートからデータを取ることはできますでしょうか？
イメージ
 
シートA シートB シートC　シートD
 
シートA,D以外から情報をとるコード
 

>オブジェクトAutoFilterのメソッド'Rangeが失敗しました。
 
その文章で検索したら、解決策結構みつかりますよ。
 
参考URL>>
https://ken3memo.hatenablog.com/entry/2022/03/20/202335
http://officetanaka.net/excel/vba/error/execution_error/error_1004.htm
 
>エラーシートを無視した状態で他のシートからデータを取ることはできますでしょうか？

 
「条件分岐」という言葉をご存じでしょうか？
 
参考URL>>
https://excel-ubara.com/excelvba1/EXCELVBA320.html
 
データとして使うシートと、その他のシートの違いをどうやって判断するかは、
Mowさんしかわからないので、そこを説明できれば、
アドバイスがもらえるかと思います。

> ご教授いただいたとおり、データシートではございません。
教授なぞした覚えはありませんが、それは、最初から
「処理する必要のないシート」と書くべきものです。
 
(1)シートを適切に移動して、対象とするシートをすべて、特定位置から右に再配置すれば、
   何番目から最後のシートまで実行対象とする現在の方式で十分対応できるはずです。
 
(2)対象シートが少数なら、列挙してもよいでしょう。

     For Each sh In Array("SheetA","SheetB","SheetC")
         set ws = worksheets(sh)
         ’....
     Next

     If  Not ( .Name = "SheetD"  Or  .Name = "SheetE" ) Then
         ' 処理実行
     End If

ご連絡いただきありがとうございます。
  
先ず、マルチポストに関してsimple様始めご協力いただきました方へ無碍な行為をしてしまい、大変申し訳ございませんでした。
 
当初、自分が書いたという虚偽を伝えたい意図は一切ございませんでした。
先方様へ問題が解決した旨を伝え誠意を示したい一心で投稿いたしました。
 
simple様からお教えいただいたポストに関する正しい使い方を意識し、
今後、サイトを利用する上での心得を改めてまいります。
 
 
また、ご教授いただきました内容でコードを書き直し、皆様からのご協力で成功することができました。
ありがとうございました。

伝わってよかったです。
それでは、「解決済みにする」にチェックを入れて閉じて下さい。