質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.59%

【VBA】対象期間内チェックの方法

解決済

回答 2

投稿

  • 評価
  • クリップ 0
  • VIEW 4,010

score 15

前提・実現したいこと

【実施したいこと】 先週月曜日~今週月曜日までの8日間が対象ファイル内の日付に該当しているかをチェックしたい。

VBA初心者です。アクセスログの分析ツールを作成しております。(週一で分析)
ロジックが思い浮かばないため、皆様のお知恵をお貸しいただけますと幸いです。

・ファイル数は連休の場合も含み2~6個で、ファイル内の日付は全ファイル合わせて9日分ほどあり、分刻みで集計を行うため万単位のデータがあります。
・祝日など何もない通常の場合はファイルの中身は以下のようになっております。
1つめのファイル:先々週の土曜日の途中から、先々週の日曜日、先週の月曜日、先週の火曜日の途中まで
2つめのファイル:先週の火曜日の途中から、先週の水曜日の途中まで
3つめのファイル:先週の水曜日の途中から、先週の木曜日の途中まで
4つめのファイル:先週の木曜日の途中から、先週の金曜日の途中まで
5つめのファイル:先週の金曜日の途中から、先週の土曜日の途中まで
6つめのファイル:先週の土曜日の途中から、先週の日曜日、今週の月曜日、今週の火曜日の途中まで

しかし、連休や祝日があった場合はファイル数が変動し(出勤日にログファイルを取得するため)、それに伴いファイル内の曜日も上記とは異なってしまいます。
ファイル数が変動してもログは毎日記録されているので、例えばファイル数が3つしかない場合でも先週の月曜日~今週の月曜日の8日間は3ファイルの中に詰め込まれて存在します。

ファイル数とファイル内の曜日が固定ではないため、コードの組み方で苦戦しております。
「試したこと」に記載のコードを考えてみましたが、下記の点で詰まってしまいました。
・8日間全て見つかった場合はcount変数に「8」が入り、その結果でOKでもいいかもしれないが、全ファイルを参照するので無駄な作業が多い。
⇒該当した曜日があった場合、以降はその曜日チェックのみを飛ばしたい。
・該当しない曜日があった場合、「〇〇曜日はありませんでした。」とのメッセージを表示させるために「msg_(曜日)」変数へ格納する処理を入れているが、全ファイルを参照するためどこかのファイルで該当しない曜日があるのは当然。
全ファイルを参照した上で8日間に該当する日付がない場合、「〇〇曜日がありませんでした。」と表示するにはどのようにコードを組めばよいか。

以上となります。
find関数ではなく別の関数を使用した方が良い、根本的にコードの組み方がおかしい等、何かアドバイスいただけますと幸いです。
お手数をおかけいたしますが、よろしくお願いいたします。

試したこと

'型変換などあまり重要でない処理は省いております。

Sub filecheck()

Dim folderPath,filename As String
Dim num,LastRow,i,count,x As Long
Dim lastMonday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday,thisMonday As date
Dim msg_lastMonday, msg_Tuesday,msg_Wednesday,msg_Thursday,msg_Friday,msg_Saturday,msg_Sunday,msg_thisMonday As String
Dim sh_act As Worksheet, sh_wrk As Worksheet



folderPath = ThisWorkbook.Worksheets(1).Cells(4, 5)  '「フォルダ選択」ボタンを押下し、選択されたディレクトリを「folderPath」へ格納する


Set sh_act = ActiveSheet
filename = Dir(folderPath & "\*.xls")                 '拡張子が「.xls」のファイルをすべて取得する。


lastMonday = ThisWorkbook.Worksheets(1).Cells(8, 5)    '作業者が先週の月曜日をE8セルに入力し、その日付を「lastMonday」へ格納する


Tuesday = DateAdd("d", 1, lastMonday)                       'lastMonday2 + 1日後⇒先週の火曜日
Wednesday = DateAdd("d", 2, lastMonday)                     'lastMonday2 + 2日後⇒先週の水曜日
Thursday = DateAdd("d", 3, lastMonday)                      'lastMonday2 + 3日後⇒先週の水曜日
'...今週の月曜日まで

 count = 0          '日付が見つかった場合のカウント用
 i = 0              'ループのカウント用


Do While i < num   '「num」は別途ファイル数チェックの戻り値です。(ファイル数分ループする)    

 Set sh_wrk = Workbooks.Open(folderPath & "\" & filename).Sheets(1)         'ファイルを開く

 LastRow = sh_wrk.Range("A1").End(xlDown).Row                               'ログファイルの最終行

  i = i + 1          '何番目のブックか数える
    x = 1        '行数カウント用

   
          'ファイル内に「先週の月曜日の日付があるか」を検索する。

          Set myRange = Range("A" & x & ":" & "A" & LastRow)
          Set myObj = myRange.find(lastMonday, LookAt:=xlPart)                                                                       
       If myObj Is Nothing Then
                   msg_lastMonday = "'" & lastMonday & "'はありませんでした"

         Else
                       count = count + 1       '「先週の月曜日」が見つかった場合、を変数「count」に1を足す                                                                               

              End If

           'ファイル内に「先週の火曜日の日付があるか」を検索する。

          Set myRange = Range("A" & x & ":" & "A" & LastRow)
          Set myObj = myRange.find(Tuesday, LookAt:=xlPart)   

       If myObj Is Nothing Then
                   msg_Tuesday = "'" & Tuesday & "'はありませんでした"

             Else
                         count = count + 1       '「先週の火曜日」が見つかった場合、を変数「count」に1を足す


      '...今週の月曜日まで続きます。


filename = Dir()
 Loop

End Sub
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

+1

やりたいことは、
先週の月曜日~今週の月曜日の8日間の日付がExcelファイル内に抜けなく存在するかどうかのチェックですね。

ロジックの一例

①日付を格納する配列を用意して、8日分の日付を格納する。
 別途、その日付が存在するかどうかを格納する配列も用意する。

②Dir関数で該当ファイルをループで取得して開く。

 ③ For Nextループで日付を検索する。
  日付存在配列をチェックしてその日付が存在しなければ
   シートのログデータをFindで検索。
    見つかれば、日付存在配列にTrueを代入

④ループで日付存在配列をチェックする。
 日付が存在しない場合、その日付を文字列に連結していく。


⑤文字列が "" なら「すべてありました」とメッセージ
 ""でなければ、文字列 & 「がありませんでした」とメッセージ

上記をコード化すると、

   '①
    Dim LogDate(0 To 7) As Date
    Dim LogDateExist(0 To 7) As Boolean
    LogDate(0) = #4/1/2019#
    For i = 1 To 7
        LogDate(i) = LogDate(0) + i
    Next

    '②
    Dim i As Long
    filename = Dir(folderPath & "\*.xls")
    Do Until filename <> ""
        With Workbooks.Open(folderPath & "\" & filename).Sheets(1) 
            '③
            For i = 0 To 7
                If Not LogDateExist(i) Then
                    Set findRng = .Range("A1:A" & LastRow).Find(LogDate(i), LookAt:=xlPart) 
                    If Not findRng Is Nothing Then
                        LogDateExist(i) = True
                    End If
                End If
            Next
        End With
        filename = Dir()
    Loop

    '④
    Dim NoDates As String
    For i = 0 To 7
        If Not LogDateExist(i) Then
            NoDates = NoDates & "," & Format(LogDate(i), "m/d(aaa)")
        End If
    Next

    '⑤
    If NoDates = "" Then
        MsgBox "すべてありました。"
    Else
        MsgBox Mid(NoDates, 2) & "がありませんでした。"
    End If

変数宣言など細かい部分は省略しているの実際は動作しません。
ロジックの参考にしてください。

高速化

アクセスログということなので、データは日付/時刻の昇順になってますよね。
ならば、Findの代わりにMatch関数を使うと高速化できます。
速度に不満がある場合は変更してください。

提示のコードで気になる点

Dim folderPath,filename As String

これは、folderPath, filename をString型で宣言したつもりでしょうが、
folderPath は型宣言を省略したことになり Variant型になります。
面倒でも、

Dim folderPath As String, filename As String

と一つずつ宣言してください。
他の変数宣言も同様です。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/04/08 16:50

    ご丁寧にご回答くださり本当にありがとうございます。
    コードが綺麗で非常に分かりやすく感動いたしました。
    教えていただいたコードを元に再作成してみます。
    また、変数宣言時の注意点につきましても恥ずかしながら存じ上げておりませんでした。
    教えてくださりありがとうございます。

    キャンセル

+1

ファイル数とファイル内の曜日が固定ではないため、コードの組み方で苦戦しております。

特定のフォルダーにある事が前提ですが、フォルダの階層読み込みを使うといいでしょう。私のプロフィールにフォルダの階層読込のコードが書かれたURLがありますので是非お使い下さい。

ファイル名に日付が挿入されているなら、VBAには「Date(日付)型」という型が存在するので型に当てはめれば日付を取得することが出来ます。「〇〇曜日はありませんでした。」と表示するのも可能です。

'ファイル内に「先週の月曜日の日付があるか」を検索する。

ここのコメントは何をしていますか?
基本的に同じコードならFor文が存在しますので使いましょう。

Dim lastMonday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday,thisMonday As date
Dim msg_lastMonday, msg_Tuesday,msg_Wednesday,msg_Thursday,msg_Friday,msg_Saturday,msg_Sunday,msg_thisMonday As String
Dim sh_act As Worksheet, sh_wrk As Worksheet


ここも配列を使えば、こんなに作る必要はありませんね。
こちら等を参考に配列の勉強をした方がより洗練されたソースコードが書けますよ。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/04/08 15:53

    確かにそうですね。。
    RPAですか。調べてみましたがマクロよりも広範囲で自動化出来るのですね。

    キャンセル

  • 2019/04/08 16:10

    流石にOCRとか画像分析は出来ませんが、windows限定ならRPAの大半の事はVBAでも可能ですよ。

    キャンセル

  • 2019/04/08 16:44

    そうなのですね。勉強になります。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.59%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る