【VBA】取り込んだデータをある条件ではスキップして使えるようにしたい

作ってるもの

エクセルを読み込んで下図のようにデータを抽出するコードを書きました。
データは読み込むと「データ」シートの左から順に埋まっていきます。

先ほどのデータを「１月」シートで利用しています。
時間帯別の数量がE列で計算されていきます。
日付が下にいくに連れて計算式は「データ」の$A→$B→$Cとなってます。

日付には条件付き書式で
「=WEEKDAY($A5,2)>= 6」で灰色の網掛けをしています。

###やりたいこと
①土曜または日曜のE列にある計算式は無し。スキップして次の日付からまたCOUNTIFSの計算をしたい。
例：
金曜：$A → 土曜：$B → 日曜：$C　これを
金曜：$A → 月曜：$B → 火曜：$C（土日スキップ）こうしたい

②翌月シートを作ったときには翌月用のデータから読み込めるようにしたい。（「データ」１シートで１月分）
また、翌月作成ボタンを押した時には日付列の日付も更新されてほしい。

データのコード

    Dim export  'Excelファイルのシート名を入れ込む変数'
    Dim Exe_Import_File  'Excelファイルに取り込むCSVファイルの名前を入れ込む変数'
    
    export = ActiveSheet.Name  '現在アクティブなシート名を変数 export に入れ込む'
    
    Exe_Import_File = Application.GetOpenFilename("ブック, *.xls")  'エクセルファイルを選択する'
    If Exe_Import_File = "False" Then Exit Sub  'キャンセルなら終了'
    
    '画面更新の非表示
    Application.ScreenUpdating = False
    
    '新しいシートとしてシートの最後にコピー、挿入
    Worksheets().Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "受付履歴"
    
    Application.DisplayAlerts = False
    Sheets("データ").Visible = True
    
    With Workbooks.Open(Exe_Import_File)
        .Sheets(1).Cells.Copy ThisWorkbook.Sheets("受付履歴").Range("A1")  '全てのデータをこのブックの「受付履歴」シートにコピー'
        .Close  'ファイルを閉じる'
    End With
      
    'BとCの間に列を挿入
    Columns("C").Insert
    Columns("F").Insert
    
    '発注依頼日を日付と時間に分ける
    'B列の9以降を選択、区切り位置でハイフンで区切る
    Range(Range("B9"), Cells(Rows.Count, 2).End(xlUp)).Select
    Selection.TextToColumns Destination:=Range("B9"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=" ", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Application.DisplayAlerts = False
    
    'ドーナツ、コーヒー、ケーキを抽出するために分割
    Range(Range("E9"), Cells(Rows.Count, 5).End(xlUp)).Select
    Selection.TextToColumns Destination:=Range("E9"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="　", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Application.DisplayAlerts = False
    
    'ドーナツ、コーヒー、ケーキを消すための変数宣言
    Dim i As Long
    Dim LstRow As Long
    Dim Code As String
    
    '最終行の取得
    'Cellの中の「5」は5列目の行（コードの列）を指す
    LstRow = Cells(Rows.Count, 5).End(xlUp).Row
    
    '繰り返し処理
    For i = LstRow To 1 Step -1
        Code = Cells(i, 5).Value
        
        '削除したいコードを""の中に入れる。//コード汚い
        If Code = "ドーナツ" Then
                Rows(i).Delete
        End If
        
                If Code = "コーヒー" Then
                Rows(i).Delete
        End If
        
                If Code = "ケーキ" Then
                Rows(i).Delete
        End If
    Next
    
    'F列の削除
    Columns("F").Delete
    
    '時間内で人数をカウント。※人数だけ
    'C列で重複しているものは削除
    Dim a As Long
    With Range("C9")
        For a = .CurrentRegion.Rows.Count To 1 Step -1
            If .Offset(a, 0) = .Offset(a - 1, 0) Then .Offset(a, 0).EntireRow.Delete
        Next a
    End With
    
    '受付履歴の時間を"データ"シートに保存しておく
    Range("B9").Copy
    Range("C8").Select
    ActiveSheet.Paste
    
    Range(Range("C8"), Cells(Rows.Count, 3).End(xlUp)).Copy ThisWorkbook.Sheets("データ").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)

    
    'B9を"基"シートのA列最終行にペーストしていきたい
    
    Sheets("受付履歴").Delete
    
    '"データ"を非表示にしておく
    'Sheets("データ").Visible = False
    
    Sheets(1).Select

翌月シート作成のコード

    'バックグラウンドで作動
    Application.ScreenUpdating = False
    
    Dim i As Integer

    '最後のシートをコピーしその後ろに追加
    Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count)

    '名前を変更
    i = Left(Sheets(Sheets.Count - 1).Name, Len(Sheets(Sheets.Count - 1).Name) - 1)
    Sheets(Sheets.Count).Name = IIf(i + 1 > 12, 1, i + 1) & "月"
    
    Range("G5:G345").ClearContents

説明が難しくごちゃごちゃとしてしまいましたが、
どなたかお力添え頂けると幸いです…
宜しくお願い致します。

yuuskeccho

2020/01/24 12:38 編集

提示されたコードには記述が無いように見えるんですが、 ”翌月シート作成のコード”を実行した後、一月分の”データ”シートはどうなりますか？例えば、今現在”1月”シートを使って”データ”シートを数式で参照しているとして、質問のやりたいことの中に”（「データ」１シートで１月分）”とあるのであれば ”2月”シートを作成した時に”データ”シートは使えなくなりますよね？この”データ”シートの行方次第で、やりたいこと①の回答も変わると思いますが。

yureighost

2020/01/26 02:19

例ではデータシートは10月の物でそれを1月のシートに読んでますが、データシートの日付部分に特に意味はなく、左から順番に土日はスキップして読みたいって要望でよろしいですか？またYuusukecchoさんの質問に近いですが、例でやってるように関数でやるとどうしても別シートを参照する形式になるので月シートの増加に応じてデータシートも増やさないと難しいです。 VBAなら読み込んで値として書き出せるので読み取った後ならデータシートは不要になりますが、 Excel関数でやるのとVBAでやるのどちらを想定していますか？

Jonny_dayo

2020/01/27 02:02

回答ありがとうございます！連絡遅くなりましてすみません、ご質問頂いた件ですが、現状"データ"シートを増やせていないため、データシートの日付に連動して値を読み込めるようにしたらシート1枚でもよいかつ土日スキップができるのかな？と思っていましたが、他にやり方がわからなかったためこの形となっております。＞Excel関数でやるのとVBAでやるのどちらを想定していますか？後々、1時間毎、30分毎、10分毎の3表示の切り替えができるようにしたいので別シートがあったほうが良いかと思ったのですが、VBAでもそれは可能なのでしょうか？

行動規範の内容に同意します

回答2件

ベストアンサー

”データ”シートに1年分の値を追記していくとして、、、

”1月”シートの

○セル[A16]
=IFERROR(IFS(MONTH(A5)=MONTH(A5+1),A5+1),"")

○セル[A27:A335] の日付箇所
セル[A16]をコピペ

○セル[E5]
=IFERROR(COUNTIFS(INDIRECT("データ!R2C"&MATCH(OFFSET($A5,0,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A5,0,0),データ!$1:$1,0),FALSE),">="&C5,INDIRECT("データ!R2C"&MATCH(OFFSET($A5,0,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A5,0,0),データ!$1:$1,0),FALSE),"<"&TIME(HOUR(C5)+1,0,0)),0)

○セル[E6]
=IFERROR(COUNTIFS(INDIRECT("データ!R2C"&MATCH(OFFSET($A6,-1,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A6,-1,0),データ!$1:$1,0),FALSE),">="&C6,INDIRECT("データ!R2C"&MATCH(OFFSET($A6,-1,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A6,-1,0),データ!$1:$1,0),FALSE),"<"&TIME(HOUR(C6)+1,0,0)),0)

○セル[E7]
=IFERROR(COUNTIFS(INDIRECT("データ!R2C"&MATCH(OFFSET($A7,-2,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A7,-2,0),データ!$1:$1,0),FALSE),">="&C7,INDIRECT("データ!R2C"&MATCH(OFFSET($A7,-2,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A7,-2,0),データ!$1:$1,0),FALSE),"<"&TIME(HOUR(C7)+1,0,0)),0)

　～～～　省略　～～～

○セル[E15]
=IFERROR(COUNTIFS(INDIRECT("データ!R2C"&MATCH(OFFSET($A15,-10,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A15,-10,0),データ!$1:$1,0),FALSE),">="&C15,INDIRECT("データ!R2C"&MATCH(OFFSET($A15,-10,0),データ!$1:$1,0)&":R999C"&MATCH(OFFSET($A15,-10,0),データ!$1:$1,0),FALSE),"<"&TIME(HOUR(C15)+1,0,0)),0)

○セル[E5:E15]を2日～31日[E16:E345]セルへコピペ

○”1月”シートをコピーして2月～12月のシートをあらかじめ作成しておく

○2月～12月シートのセル[A5]へその月の1日を入力しておく

このようにすれば②は必要ないと思いますが、いかがでしょうか？

投稿2020/01/27 05:10

yuuskeccho

総合スコア97

Jonny_dayo

2020/01/27 06:00

回答ありがとうございます！！これで入力したい日付のデータだけ取り込めるようになったので、①も②もクリアになりました！！ただ、日付の ○セル[A16] =IFERROR(IFS(MONTH(A5)=MONTH(A5+1),A5+1),"") ○セル[A27:A335] の日付箇所セル[A16]をコピペの部分が上手くいかず、A5に例えば「1/1」と入力してもA16以降に日付が反映されないのですが、入力の仕方？とかが良くないのでしょうか…？

yuuskeccho

2020/01/27 06:23 編集

ん～、セルの書式設定から表示形式を確認して　m"月"d"日"(aaa)　←これになってますか？セル[A16]は、 =IF(A5="","",IF(MONTH(A5)=MONTH(A5+1),A5+1,"")) ↑これでもいいと思うんですが。

Jonny_dayo

2020/01/27 06:48

わあー！！ =IF(A5="","",IF(MONTH(A5)=MONTH(A5+1),A5+1,"")) にしたらいけましたありがとうございます(*'ω'*)♡ ちなみに書式はm"月"d"日"(aaa)になっていました！

yuuskeccho

2020/01/27 06:51

とりあえず出来て良かったです。あとは、日付に対する時間帯ごとのカウントが正しいかを必ず確認して下さい。宜しくお願いします。

行動規範の内容に同意します

んと。
こんなデータがあるとして、

まずは1行1件のデータに変換します。

ExcelVBA
1'表を一覧に変換
2Sub TableToList()
3    Dim vv As Variant
4    Dim v() As Variant
5    Dim i As Long, j As Long, k As Long
6
7    With Worksheets("Sheet1").Range("A1").CurrentRegion
8        vv = .Value
9        k = .Count
10    End With
11    ReDim v(1 To k)
12    k = 0
13
14    For j = 1 To UBound(vv, 2)
15        For i = 2 To UBound(vv, 1)
16            k = k + 1
17            v(k) = vv(1, j) + vv(i, j)
18        Next
19    Next
20
21    With Worksheets("Sheet2")
22        .UsedRange.ClearContents
23        .Range("A1").Value = "日時"
24        .Range("A2").Resize(k).Value = WorksheetFunction.Transpose(v)
25    End With
26End Sub

1行1件に変換したら、（画面は時間が見えてないですが、時間も同じセル内に入ってます。）
平日と指定月のデータをフィルターオプションで抽出します。

ExcelVBA
1'平日を抽出
2Sub Weekdays()
3    Dim rngList As Range
4    Dim rngCriteria As Range
5    Dim rngCopyTo As Range
6    
7    With Worksheets("Sheet2")
8        Set rngList = .Range("A1").CurrentRegion
9        Set rngCriteria = .Range("C1:F2")
10        Set rngCopyTo = .Range("C5")
11    End With
12    
13    With rngCriteria
14        .Cells(2, 1).Formula = "=Weekday(A2)<>1"
15        .Cells(2, 2).Formula = "=weekday(A2)<>7"
16        .Cells(1, 3).Value = "日時"
17        .Cells(2, 3) = ">=2019/10/1"
18        .Cells(1, 4).Value = "日時"
19        .Cells(2, 4) = "<2019/11/1"
20    End With
21        
22    rngCopyTo.Value = rngList.Cells(1).Value
23    
24    rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo
25End Sub

抽出したらピボットテーブルで時間毎に集計します。

ExcelVBA
1'ピボットテーブルで集計
2Sub RunPivotTable()
3    Dim pvtCache As PivotCache
4    Dim pvtTable As PivotTable
5    Dim a
6
7    Set pvtCache = ThisWorkbook.PivotCaches.Create( _
8                   SourceType:=xlDatabase, SourceData:=Worksheets("Sheet2").Range("C5").CurrentRegion)
9    Set pvtTable = pvtCache.CreatePivotTable(Worksheets("Sheet3").Range("A1"))
10
11    With pvtTable
12        .PivotFields("日時").Orientation = xlRowField
13        .PivotFields("日時").Orientation = xlDataField
14        .RowRange.Cells(2).Group Periods:=Array(False, False, True, True, True, False, True)
15        .PivotFields("日").Subtotals(1) = True
16        .RowAxisLayout xlTabularRow
17        .RepeatAllLabels xlRepeatLabels
18    End With
19End Sub

出来た表を自分好みに編集します。

ExcelVBA
1'ピボットテーブルの結果を編集
2Sub MakeTable()
3    Dim o As Range
4    Dim a As Range
5    
6    Set o = Worksheets("Sheet3").PivotTables(1).PivotFields("日").DataRange.Resize(, 3)
7    With Worksheets("Sheet4").Range("A2")
8        o.Copy .Cells
9        .Worksheet.UsedRange.Columns(2).Insert xlShiftToRight
10        Application.DisplayAlerts = False
11        For Each a In .Worksheet.UsedRange.Columns(3).SpecialCells(xlCellTypeConstants).Areas
12            a.Cells(1, 3).Value = a.Cells(a.Rows.Count + 1, 2).Value
13            a.Offset(, 2).Merge
14            a.Offset(, -1).Merge
15            a.Offset(, -2).Merge
16            a.Cells(a.Rows.Count + 1, 2).EntireRow.Delete
17        Next
18        Application.DisplayAlerts = True
19    End With
20End Sub