回答編集履歴

1

コード追記

2020/09/29 15:21

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -47,3 +47,91 @@
47
47
  End With
48
48
 
49
49
  ```
50
+
51
+
52
+
53
+ ---
54
+
55
+
56
+
57
+ こちらで作成したサンプルでは下記で動いてます。
58
+
59
+
60
+
61
+ ```vba
62
+
63
+ Sub SheetTenki()
64
+
65
+ '
66
+
67
+ Dim ec As Long '年月の一番左から一番右までを取得
68
+
69
+ Dim lngFromRowsNo As Long ' 検索する行位置
70
+
71
+ Dim lngToRowsNo As Long ' 書きこむ行位置
72
+
73
+ Dim wsFrom As Worksheet ' 取得側Excelシート
74
+
75
+ Dim wsTo As Worksheet ' 設定側Excelシート
76
+
77
+
78
+
79
+ Dim datMax As Date '日付最大値
80
+
81
+ Dim datMin As Date '日付最小値
82
+
83
+
84
+
85
+ 'シート"質問1"を選択
86
+
87
+ Set wsFrom = Worksheets("質問1")
88
+
89
+
90
+
91
+ 'D列を上から検索していき、yyyy/mm/dd形式のセルを抽出する
92
+
93
+ For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
94
+
95
+ If IsDate(wsFrom.Cells(lngFromRowsNo, 4).Value) Then
96
+
97
+
98
+
99
+ '抽出した行の年月を値が含まれる最大まで(右側)取得
100
+
101
+ '?1は見込み合計を含まないため
102
+
103
+ ec = wsFrom.Cells(lngFromRowsNo, 4).End(xlToRight).Column - 1
104
+
105
+
106
+
107
+ '取得した年月の最大値と最小値を求めて、最小値から最大値までを1ヶ月間隔で転記していく
108
+
109
+ With WorksheetFunction
110
+
111
+ datMax = .Max(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
112
+
113
+ datMin = .Min(Range(wsFrom.Cells(lngFromRowsNo, 4), wsFrom.Cells(lngFromRowsNo, ec)))
114
+
115
+ End With
116
+
117
+ 'どこに転記するか不明なのでとりあえずメッセージボックスに表示
118
+
119
+ MsgBox "最大値:" & datMax & " 最小値:" & datMin
120
+
121
+
122
+
123
+ ' 次の行へ
124
+
125
+ lngToRowsNo = lngToRowsNo + 1
126
+
127
+
128
+
129
+ End If
130
+
131
+ Next lngFromRowsNo
132
+
133
+
134
+
135
+ End Sub
136
+
137
+ ```