VBA シート間の転記をする際に日付の最大値と最小値を求めて、1ヶ月ごとに転記していきたい。

Question

エクセルのシート間の値のコピー処理で
日付の最大値と最小値を取得して、最小値から最大値まで1ヶ月ごとに転記していきたいです。

何卒、よろしくお願いします。

実現したいこと

このような手順で処理を行っていこうと考えています。
結果的に[転記先]のように転記したい。

[質問１シート]1行目　D列の値がyyyy/mm/dd形式ではない
→無処理

[質問１シート]２行目　D列の値がyyyy/mm/dd形式である
→年月の値を取得し、取得した全ての日付の最小値と最大値を求める
...
以降、yyyy/mm/dd形式かそうでないかで処理の繰り返し

転記元

転記先

困っている事

上記「実現したいこと」記載の
「各行で年月の値を取得し、最小値と最大値を求める」処理の方法がわかりません。→解決済み

ご回答いただいた内容を参照して、ソースを作成し直したが（現在まで完成しているコード）
「オブジェクト変数またはWithブロック変数が設定されていません」
という内容のエラーメッセージが出てしまう。

現在まで完成しているコード

Sub SheetTenki()
'
    Dim ec As Long    '年月の一番左から一番右までを取得
    Dim lngFromRowsNo As Long    ' 検索する行位置
    Dim lngToRowsNo As Long    ' 書きこむ行位置
    Dim wsFrom As Worksheet    ' 取得側Excelシート
    Dim wsTo As Worksheet    ' 設定側Excelシート

    Dim datMax As Date    '日付最大値
    Dim datMin As Date    '日付最小値
    Dim enddatMax As Date    ' 最終的な日付最大値
    Dim enddatMin As Date    '最終的な日付最小値
    Dim ToColumnNo As Long
    
    enddatMax = #1/1/100#      '日付最大値に最小値を設定
    enddatMin = #1/1/9999#    '日付最最少値に最大値を設定
    ToColumnNo = 4
    
    
'シート"質問１"を選択
    Set wsFrom = Worksheets("質問１")

    'D列を上から検索していき、yyyy/mm/dd形式のセルを抽出する
    For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
        If IsDate(wsFrom.Cells(lngFromRowsNo, 4).Value) Then

            '抽出した行の年月を値が含まれる最大まで（右側）取得
            '?１は見込み合計を含まないため
            ec = wsFrom.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1

            '取得した年月の最大値と最小値を求めて、最小値から最大値までを1ヶ月間隔で転記していく
            With WorksheetFunction
                datMax = .Max(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
                datMin = .Min(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
            End With
            'どこに転記するか不明なのでとりあえずメッセージボックスに表示
             'MsgBox "最大値:" & datMax & " 最小値:" & datMin
             
            If enddatMin > datMin Then
             enddatMin = datMin
            End If
            If enddatMax < datMax Then
              enddatMax = datMax
            End If

            ' 次の行へ
            lngToRowsNo = lngToRowsNo + 1
            
        End If
        
    Next lngFromRowsNo
    
        Do
          wsTo.Cells(2, ToColumnNo).Value = enddatMin
          ToColumnNo = ToColumnNo + 1 '次の列へ
           enddatMin = DateAdd("m", 1, enddatMin) '一ヶ月後
            Loop Until enddatMin > enddatMax
    
End Sub

Comments

[kuma_kuma_]

>[質問１シート]1行目　D列の値がyyyy/mm/dd形式ではない
>[質問１シート]２行目　D列の値がyyyy/mm/dd形式である
質問がおかしくありませんか？
>[質問１シート]1行目　D列の値がyyyy/mm/dd形式ではない
>[質問2シート]1行目　D列の値がyyyy/mm/dd形式である
ならまだ意味が判りますが
それとも転記元の写真誤り？

Answer 1

日付がどうかの判断は IsDate関数でできます。

If IsDate(.Cells(lngFromRowsNo, 4).Value) Then
   '日付の時の処理
End If

転記元の画像を見ると、担当者 の横から日付が並んでいるので、
"担当者"を FindメソッドかIndexで検索したほうが高速だとは思います。

最大値、最小値は、Max関数とMin関数で取得できます。

  Dim ec As Long '最終列
  Dim datMax as Date '日付最大値
  Dim datMin as Date '日付最小値

  ec = wsTo.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1
  With WorksheetFunction
    datMax = .Max(Range(.Cells(lngFromRowsNo, 4), .Cells(lngFromRowsNo, ec)))
    datMin = .Min(Range(.Cells(lngFromRowsNo, 4), .Cells(lngFromRowsNo, ec)))
  End With

---

こちらで作成したサンプルでは下記で動いてます。

Sub SheetTenki()
'
    Dim ec As Long    '年月の一番左から一番右までを取得
    Dim lngFromRowsNo As Long    ' 検索する行位置
    Dim lngToRowsNo As Long    ' 書きこむ行位置
    Dim wsFrom As Worksheet    ' 取得側Excelシート
    Dim wsTo As Worksheet    ' 設定側Excelシート

    Dim datMax As Date    '日付最大値
    Dim datMin As Date    '日付最小値

'シート"質問１"を選択
    Set wsFrom = Worksheets("質問１")

    'D列を上から検索していき、yyyy/mm/dd形式のセルを抽出する
    For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
        If IsDate(wsFrom.Cells(lngFromRowsNo, 4).Value) Then

            '抽出した行の年月を値が含まれる最大まで（右側）取得
            '?１は見込み合計を含まないため
            ec = wsFrom.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1

            '取得した年月の最大値と最小値を求めて、最小値から最大値までを1ヶ月間隔で転記していく
            With WorksheetFunction
                datMax = .Max(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
                datMin = .Min(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
            End With
            'どこに転記するか不明なのでとりあえずメッセージボックスに表示
            MsgBox "最大値:" & datMax & " 最小値:" & datMin

            ' 次の行へ
            lngToRowsNo = lngToRowsNo + 1

        End If
    Next lngFromRowsNo

End Sub

Comments

[icecleam]

ご回答いただきありがとうございます。

ご回答者さまの回答を参考に以下のようにソースを修正したのですが、エラーメッセージ「メソッドまたはデータ メンバーが見つかりません。」が
datMax = .Max(Range(.Cells(lngFromRowsNo, 4), .Cells(lngFromRowsNo, ec)))
の.Cellのところで出てしまいました。
うまく実行するにはどのように修正すれば良いでしょうか。。

全体のソースコード
ーーー
Sub SheetTenki()
'
Dim ec As Long '年月の一番左から一番右までを取得
Dim lngFromRowsNo As Long ' 検索する行位置
Dim lngToRowsNo As Long ' 書きこむ行位置
Dim wsFrom As Worksheet ' 取得側Excelシート
Dim wsTo As Worksheet ' 設定側Excelシート

Dim datMax As Date '日付最大値
Dim datMin As Date '日付最小値

'シート"質問１"を選択
Sheets("質問１").Select

'D列を上から検索していき、yyyy/mm/dd形式のセルを抽出する
For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
If IsDate(wsFrom.Cells(lngFromRowsNo, 4).Value) Then

'抽出した行の年月を値が含まれる最大まで（右側）取得
'−１は見込み合計を含まないため
ec = wsFrom.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1

'取得した年月の最大値と最小値を求めて、最小値から最大値までを1ヶ月間隔で転記していく
With WorksheetFunction
datMax = .Max(Range(.Cells(lngFromRowsNo, 4), .Cells(lngFromRowsNo, ec)))
datMin = .Min(Range(.Cells(lngFromRowsNo, 4), .Cells(lngFromRowsNo, ec)))
End With

' 次の行へ
lngToRowsNo = lngToRowsNo + 1

End If
Next lngFromRowsNo

End Sub

[Usirow]

もう自己解決されてるかもしれませんが、該当の箇所は WorksheetFunctionで括られているため、以下のように書かないとエラーになりますね。

With WorksheetFunction
datMax = .Max(Range(Cells(lngFromRowsNo, 4), Cells(lngFromRowsNo, ec)))
datMin = .Min(Range(Cells(lngFromRowsNo, 4), Cells(lngFromRowsNo, ec)))
End With

[icecleam]

Usirowさんへ
以下のように修正したのですが、「オブジェクト変数またはWithブロック変数が設定されていません」というエラーメッセージが出てまいました。。
もしよければ、正常に転記するためにはどのように修正すれば良いか、教えていただけないでしょうか。。

Sub SheetTenki()
'
Dim ec As Long '年月の一番左から一番右までを取得
Dim lngFromRowsNo As Long ' 検索する行位置
Dim lngToRowsNo As Long ' 書きこむ行位置
Dim wsFrom As Worksheet ' 取得側Excelシート
Dim wsTo As Worksheet ' 設定側Excelシート

Dim datMax As Date '日付最大値
Dim datMin As Date '日付最小値

'シート"質問１"を選択
Sheets("質問１").Select

'D列を上から検索していき、yyyy/mm/dd形式のセルを抽出する
For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
If IsDate(wsFrom.Cells(lngFromRowsNo, 4).Value) Then

'抽出した行の年月を値が含まれる最大まで（右側）取得
'−１は見込み合計を含まないため
ec = wsFrom.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1

'取得した年月の最大値と最小値を求めて、最小値から最大値までを1ヶ月間隔で転記していく
With WorksheetFunction
datMax = .Max(Range(Cells(lngFromRowsNo, 4), Cells(lngFromRowsNo, ec)))
datMin = .Min(Range(Cells(lngFromRowsNo, 4), Cells(lngFromRowsNo, ec)))
End With

' 次の行へ
lngToRowsNo = lngToRowsNo + 1

End If
Next lngFromRowsNo

End Sub

[hatena19]

回答に追記しましたので参照してください。

[icecleam]

今参照をして、実行して見たところそれぞれの最大値と最小値を取得することができました！

あと申し訳ないのですが、これを質問の「転記先」のように転記するにはどうすれば良いのでしょうか。。

[hatena19]

kuma_kuma_ さんの回答の2番目のコードと組み合わせれば、全体の最大値と最小値が求められます。

全体の最大値と最小値が求められたら、下記のコードで転記先に転記できます。

Dim ToColumnNo As Long
ToColumnNo = 4
Do
wsTo.Cells(2, ToColumnNo).Value = datMin
ToColumnNo = ToColumnNo + 1 '次の列へ
datMin = DateAdd("m", 1, datMin) '一ヶ月後
Loop Until datMin > datMax

[icecleam]

ありがとうございます。
今、上記の対応をしようとしていたのですが、以下のように組み合わせて実行したら、またまた「オブジェクト変数またはWithブロック変数が設定されていません」というエラーメッセージが出てしまいました。

正常に実行するにはどう修正すれば良いでしょうか。。
ラリーが長くなってしまい申し訳ありませんが、お付き合いいただけると幸いです。。

[追記]
質問の内容にも、ここまでご回答いただいた内容を反映させていただきました。
可能であれば、ご回答をいただきたいです。。

ソース
-----
Sub SheetTenki()
'
Dim ec As Long '年月の一番左から一番右までを取得
Dim lngFromRowsNo As Long ' 検索する行位置
Dim lngToRowsNo As Long ' 書きこむ行位置
Dim wsFrom As Worksheet ' 取得側Excelシート
Dim wsTo As Worksheet ' 設定側Excelシート

Dim datMax As Date '日付最大値
Dim datMin As Date '日付最小値
Dim enddatMax As Date ' 最終的な日付最大値
Dim enddatMin As Date '最終的な日付最小値
Dim ToColumnNo As Long

enddatMax = #1/1/100# '日付最大値に最小値を設定
enddatMin = #1/1/9999# '日付最最少値に最大値を設定
ToColumnNo = 4

'シート"質問１"を選択
Set wsFrom = Worksheets("質問１")

'D列を上から検索していき、yyyy/mm/dd形式のセルを抽出する
For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
If IsDate(wsFrom.Cells(lngFromRowsNo, 4).Value) Then

'抽出した行の年月を値が含まれる最大まで（右側）取得
'?１は見込み合計を含まないため
ec = wsFrom.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1

'取得した年月の最大値と最小値を求めて、最小値から最大値までを1ヶ月間隔で転記していく
With WorksheetFunction
datMax = .Max(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
datMin = .Min(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
End With
'どこに転記するか不明なのでとりあえずメッセージボックスに表示
'MsgBox "最大値:" & datMax & " 最小値:" & datMin

If enddatMin > datMin Then
enddatMin = datMin
End If
If enddatMax < datMax Then
enddatMax = datMax
End If

' 次の行へ
lngToRowsNo = lngToRowsNo + 1

End If

Next lngFromRowsNo

Do
wsTo.Cells(2, ToColumnNo).Value = enddatMin
ToColumnNo = ToColumnNo + 1 '次の列へ
enddatMin = DateAdd("m", 1, enddatMin) '一ヶ月後
Loop Until enddatMin > enddatMax

End Sub

[kitasue]

https://teratail.com/questions/294906
の私の回答でうまく行きませんか？

[hatena19]

Set wsFrom = Worksheets("質問１")
の後に、下記のコードを追加してみてください。
Set wsTo = Worksheets("質問２")

[icecleam]

Set wsTo = Worksheets("質問２")
を追記したら無事に実行できました！

本当に助かりました、ありがとうございました！

[icecleam]

すみません、もしよければお答えいただきたいのですが
今回のプログラムでdate関数を使用している箇所をStringで表現し、出力する際には日の部分を出力しないようにしたいのですが、その場合はどのような修正をすれば良いでしょうか。
お手数ですが教えていただければ幸いです。

[hatena19]

wsTo.Cells(2, ToColumnNo).Value = enddatMin
この部分のことでしょうか。下記のようにすれば年月の表示になると思います。
wsTo.Cells(2, ToColumnNo).Value = Format(enddatMin,"yyyy/mm")

ただ、日付(Date型)のままにしておいて、セルの書式設定でユーザ定義書式て yyyy/mm と設定しておく方がいいと思います。

Answer 2

まずLike演算子を使いましょう

If 値 like "####/*#/*#" then
'年月日
ElseIf 値 like "####/*#" then
'年月
ENDIF

Dim datMax as Date '日付最大値
Dim datMin as Date '日付最小値　
datMax = #100/01/01#  '日付最大値に最小値を設定
datMin = #9999/01/01# '日付最最少値に最大値を設定
'あとはループして文字列を日付型に変換し大小判定して代入していく

If datMin > 値 Then
    datMin = 値
ENd If
If datMax < 値 Then
    datMax = 値
ENd If

文字列からDate型に変換するのはCDateを使う

Dim datDate as Date 
datDate = CDate("2020/09/28")