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

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

ただいまの
回答率

87.78%

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

解決済

回答 2

投稿

  • 評価
  • クリップ 2
  • VIEW 1,092

score 43

作ってるもの

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

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

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

やりたいこと

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

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

データのコード

    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

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

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

質問への追記・修正、ベストアンサー選択の依頼

  • yuuskeccho

    2020/01/24 21:37 編集

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

    キャンセル

  • yureighost

    2020/01/26 11:19

    例ではデータシートは10月の物でそれを1月のシートに読んでますが、
    データシートの日付部分に特に意味はなく、
    左から順番に土日はスキップして読みたいって要望でよろしいですか?

    またYuusukecchoさんの質問に近いですが、
    例でやってるように関数でやるとどうしても別シートを参照する形式になるので
    月シートの増加に応じてデータシートも増やさないと難しいです。
    VBAなら読み込んで値として書き出せるので読み取った後ならデータシートは不要になりますが、
    Excel関数でやるのとVBAでやるのどちらを想定していますか?

    キャンセル

  • Jonny_dayo

    2020/01/27 11:02

    回答ありがとうございます!連絡遅くなりましてすみません、
    ご質問頂いた件ですが、現状"データ"シートを増やせていないため、
    データシートの日付に連動して値を読み込めるようにしたらシート1枚でもよいかつ土日スキップができるのかな?と思っていましたが、他にやり方がわからなかったためこの形となっております。

    >Excel関数でやるのとVBAでやるのどちらを想定していますか?
    後々、1時間毎、30分毎、10分毎の3表示の切り替えができるようにしたいので別シートがあったほうが良いかと思ったのですが、VBAでもそれは可能なのでしょうか?

    キャンセル

回答 2

checkベストアンサー

+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 15:00

    回答ありがとうございます!!
    これで入力したい日付のデータだけ取り込めるようになったので、①も②もクリアになりました!!
    ただ、日付の
    ○セル[A16]
    =IFERROR(IFS(MONTH(A5)=MONTH(A5+1),A5+1),"")

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

    の部分が上手くいかず、A5に例えば「1/1」と入力してもA16以降に日付が反映されないのですが、入力の仕方?とかが良くないのでしょうか…?

    キャンセル

  • 2020/01/27 15:21 編集

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

    キャンセル

  • 2020/01/27 15:48

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

    キャンセル

  • 2020/01/27 15:51

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

    キャンセル

+1

んと。
こんなデータがあるとして、
イメージ説明

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

'表を一覧に変換
Sub TableToList()
    Dim vv As Variant
    Dim v() As Variant
    Dim i As Long, j As Long, k As Long

    With Worksheets("Sheet1").Range("A1").CurrentRegion
        vv = .Value
        k = .Count
    End With
    ReDim v(1 To k)
    k = 0

    For j = 1 To UBound(vv, 2)
        For i = 2 To UBound(vv, 1)
            k = k + 1
            v(k) = vv(1, j) + vv(i, j)
        Next
    Next

    With Worksheets("Sheet2")
        .UsedRange.ClearContents
        .Range("A1").Value = "日時"
        .Range("A2").Resize(k).Value = WorksheetFunction.Transpose(v)
    End With
End Sub

イメージ説明

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

'平日を抽出
Sub Weekdays()
    Dim rngList As Range
    Dim rngCriteria As Range
    Dim rngCopyTo As Range

    With Worksheets("Sheet2")
        Set rngList = .Range("A1").CurrentRegion
        Set rngCriteria = .Range("C1:F2")
        Set rngCopyTo = .Range("C5")
    End With

    With rngCriteria
        .Cells(2, 1).Formula = "=Weekday(A2)<>1"
        .Cells(2, 2).Formula = "=weekday(A2)<>7"
        .Cells(1, 3).Value = "日時"
        .Cells(2, 3) = ">=2019/10/1"
        .Cells(1, 4).Value = "日時"
        .Cells(2, 4) = "<2019/11/1"
    End With

    rngCopyTo.Value = rngList.Cells(1).Value

    rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo
End Sub

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

'ピボットテーブルで集計
Sub RunPivotTable()
    Dim pvtCache As PivotCache
    Dim pvtTable As PivotTable
    Dim a

    Set pvtCache = ThisWorkbook.PivotCaches.Create( _
                   SourceType:=xlDatabase, SourceData:=Worksheets("Sheet2").Range("C5").CurrentRegion)
    Set pvtTable = pvtCache.CreatePivotTable(Worksheets("Sheet3").Range("A1"))

    With pvtTable
        .PivotFields("日時").Orientation = xlRowField
        .PivotFields("日時").Orientation = xlDataField
        .RowRange.Cells(2).Group Periods:=Array(False, False, True, True, True, False, True)
        .PivotFields("日").Subtotals(1) = True
        .RowAxisLayout xlTabularRow
        .RepeatAllLabels xlRepeatLabels
    End With
End Sub

イメージ説明

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

'ピボットテーブルの結果を編集
Sub MakeTable()
    Dim o As Range
    Dim a As Range

    Set o = Worksheets("Sheet3").PivotTables(1).PivotFields("日").DataRange.Resize(, 3)
    With Worksheets("Sheet4").Range("A2")
        o.Copy .Cells
        .Worksheet.UsedRange.Columns(2).Insert xlShiftToRight
        Application.DisplayAlerts = False
        For Each a In .Worksheet.UsedRange.Columns(3).SpecialCells(xlCellTypeConstants).Areas
            a.Cells(1, 3).Value = a.Cells(a.Rows.Count + 1, 2).Value
            a.Offset(, 2).Merge
            a.Offset(, -1).Merge
            a.Offset(, -2).Merge
            a.Cells(a.Rows.Count + 1, 2).EntireRow.Delete
        Next
        Application.DisplayAlerts = True
    End With
End Sub


イメージ説明

こんな流れで作業をしてはいかがでしょうか?
あとは、このコードを繋げばよいかと。

時間が掛かるのでかなり雑に作ってますが、
この辺を叩き台に細かいところを詰めて行ってみてはいかがでしょうか?

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2020/01/22 14:47

    回答ありがとうございます!
    これだとある程度元のデータがそろってから使いやすいように作業して、という形ですよね…?
    まとめて作業ではなく、1日1つずつデータを読み込む作業になるため、COUNTIFSを利用した数式をどうにか工夫できないか質問させて頂いた次第でした。。
    説明不足で申し訳ございません、、

    キャンセル

  • 2020/01/27 14:23

    ドンドン蓄積すればいいように思いますが・・・
    自動で結果は得られるのですから、
    元のデータがあれば、結果なんか保存しなくても、瞬時に得られるでしょう。
    まぁ、VBAで書くならどうにでもなりますが、
    人間に合わせるより、エクセルに合わせた方が、
    開発が簡単かなぁという提案です。

    キャンセル

  • 2020/01/27 15:04

    どうもご丁寧にありがとうございます!
    完全に私の脳みそが追い付いていなくて勘違いしていました…
    そうですよね、人間が合わせるべきだったなあと思いました、ありがとうございます(´;ω;`)

    キャンセル

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

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

関連した質問

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