【Excel VBA】日付の代入

質問

現在以下の操作を行いたく、コードを作成しています。
・20～23行で各最大値を抽出し、C列に代入する
・最大値に紐づく日付をD列に代入する
・D列の日付が入ったセルを改行し、
2行目に"(曜日)"を入力する

<現在のExcelデータ詳細>
A20："処理1"
A21："処理2"
A22："処理3"
A23："処理4"
B19～AF19：日付
B20～AF23：任意の数字
C31：処理1の最大値
C33：処理2の最大値
C35：処理3の最大値
C37：処理4の最大値
D31、D33、D35、D37：日付
L(曜日)を入力予定

最大値に紐づく日付をD列に代入するところで
躓いています。
ご教示いただけないでしょうか。

現在のコードは下記の通りです。

Sub 最大値の取得()

Dim max As Long
Dim row As Integer
Dim column As Integer

For row = 20 To 23
max = 0
For column = 2 To 32
If Cells(row, column).Value > max Then
max = Cells(row, column).Value
End If
Next
Cells((row - 20) * 2 + 31, 3).Value = max

For i = 4 To 1 Step -4 '編集中
Cells((row - 20) * 2 + 31, 4).Value = Cells(row - i, column - 1) '編集中

Next

End Sub

回答No.6

kagakusuki · ベストアンサー

回答No.1,3,4です。

>後者の文字列として表示させたいと考えています。

　それでしたら

.NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する

の部分は不要ですので、以下の様にして下さい。

Sub 最大値の取得_繰返し処理版2()

Dim row As Integer '変数rowを宣言
Dim column As Integer '変数columnを宣言
Dim max As Long '変数maxを宣言
Dim temp As Variant '変数tempを宣言
Dim maxday As Variant '変数maxdayを宣言

With Application
.ScreenUpdating = False '画面表示の更新停止
.Calculation = xlManual '計算モードを手動にする
End With

Range("C31:C38").ClearContents '古いデータを消去
For row = 0 To 3 '行番号のオフセット数rowが0～3の範囲で繰り返し処理を行う
max = 0 'maxに0を代入する
For column = 2 To 32 'columnが32まで繰り返し処理を行う
temp = Cells(row + 20, column).Value 'tempに値を代入する
If IsNumeric(temp) Then '値が数値の場合
If temp > max Then 'maxより大きい値の場合
max = temp 'maxに値を代入する
maxday = Cells(19, column).Value
End If 'If temp > max Then文の終了
End If 'If IsNumeric(temp) Then文の終了
Next column 'columnの値を増分する
If max > 0 Then
With Cells(row * 2 + 31, "C")
.Value = max '最大値を転記する
With .Offset(1)
.Value = Format(maxday, "m/d" & vbCrLf & "(aaa)") '最大値に紐づく日付と曜日を表す文字列入力する
.HorizontalAlignment = xlCenter '横位置中央
.VerticalAlignment = xlCenter '縦位置中央
.WrapText = True '折り返して全体を表示する
.RowHeight = .RowHeight + .Font.Size * 1.5 '行の高さを調整する
End With
End With
End If 'If max > 0 Then文の終了
Next row 'rowの値を増分する

With Application
.Calculation = xlAutomatic '計算モードを自動にする
.ScreenUpdating = True '画面表示の更新再開
End With

End Sub

　或いは、

Sub 最大値の取得_改2()

'QNo.9077754 【Excel VBA】日付の代入

Dim i As Integer, c As Range, max As Long

With Application
.ScreenUpdating = False '画面表示の更新停止
.Calculation = xlManual '計算モードを手動にする
End With

Range("C31:C38").ClearContents '古いデータを消去
For i = 0 To 3 '行番号のオフセット数rowが0～3の範囲で繰り返し処理を行う
With Range("B20:AF20")
max = Application.WorksheetFunction.max(.Offset(i)) '最大値を求め、その求めた値を変数maxに格納
Set c = .Offset(i).Find(max, , xlValues, xlWhole) '最大値が入力されているセルがどのセルであるかを求め、そのセルを変数cに格納
End With
If Not c Is Nothing Then '最大値が入力されているセルが存在しない場合以外の場合(数値が入力されているセルが存在する場合)
With Range("C31").Offset(i * 2) 'C31セルを起点に変数iの値の2倍だけオフセットされたセル
.Value = max '最大値を転記する
With .Offset(1)
.Value = Format(Cells(19, c.column).Value, "m/d" & vbCrLf & "(aaa)") '最大値に紐づく日付と曜日を表す文字列入力する
.HorizontalAlignment = xlCenter '横位置中央
.VerticalAlignment = xlCenter '縦位置中央
.WrapText = True '折り返して全体を表示する
.RowHeight = .RowHeight + .Font.Size * 1.5 '行の高さを調整する
End With
End With
End If
Next i

With Application
.Calculation = xlAutomatic '計算モードを自動にする
.ScreenUpdating = True '画面表示の更新再開
End With

End Sub

お礼

遅くなりましたが、想定の動作を行うことができました。
回答いただき、ありがとうございました!

回答No.5

keithin

お呼びじゃないみたいですが、まぁ、人が書いたマクロの質問をされるのも迷惑でしょうから。

sub macro1r1()
　dim r as long
　dim c as long
　dim rr as long
　dim res as long

　with range("D31,D33,D35,D37")
　　.wraptext = true
　　.horizontalalignment = xlcenter
　　.numberformatlocal = "m/d" & vblf & "(aaa)"
　end with

　for r = 20 to 23
　　rr = (r - 20 ) * 2 + 31
　　res = 0
　　for c = 2 to 32
　　　if cells(r, c).value > res then
　　　’更新したら転記する
　　　　res = cells(r, c).value
　　　　cells(rr, "C").value = res　’値と
　　　　cells(rr, "D").value = cells(19, c).value’日付
　　　end if
　　next c
　next r
end sub

回答No.4

kagakusuki

>> .NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する

> この部分を改良中です。

>セルのコピーをした際に、そのまま引っ張れるようにしたいと考えています。
>.Value = maxday & vbCrLf & "(" & Format(maxday, "aaa") & ")"　'改良中

　何をどうしたいと考えておられるのかをはっきりと説明して下さい。

.NumberFormatLocal = "m/d" & vbCrLf & "aaa"

という箇所は、セルの書式設定の表示形式を指定している部分です。
　それに対して、

.Value = maxday & vbCrLf & "(" & Format(maxday, "aaa") & ")"

という箇所は、セルに入力する値を指定しているだけで、セルの書式設定の表示形式してはいないのですから、

.NumberFormatLocal = "m/d" & vbCrLf & "aaa"

の部分を改良する事にはなりません。

.NumberFormatLocal = "m/d" & vbCrLf & "aaa"

のままであっても、セルをコピーする際にセルの書式もコピーすれば、

11/1
月

の形式のままで引っ張れる事になりますが、それをどの様に改良したいのでしょうか？
　セルに入力されているデータは日付データのままで、表示形式を使って

11/1
(月)

と表示させたいのか、それともセルに入力されるデータを、Excelが日付データとして扱う事が出来ない

11/1
(月)

という文字列データで入力したいのか、どちらなのでしょうか？

補足

説明が不足しており、すみませんでした。

後者の文字列として表示させたいと考えています。

回答No.3

kagakusuki

>すみません。現状は以下コードになりました。
>Sub macro1()
(中略)
>rrow = (row - 20) * 2 + 32 'rrowに行番号を代入する
>For row = 20 To 23 'rowが23まで繰り返し処理を行う
(中略)
>Cells(rrow - 1, "C").Value = max '最大値を転記する
>Cells(rrow, "C").Value = Cells(19, column).Value '最大値に紐づく日付を入力する
>Cells(rrow, "C").NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する
(中略)
>Next column 'columnの値を増分する
>Next row 'rowの値を増分する

>End Sub

　色々と間違っています。
　まず、

Cells(rrow, "C").Value = Cells(19, column).Value '最大値に紐づく日付を入力する
Cells(rrow, "C").NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する

ではC列に日付を入力する事になりますから、

>D31、D33、D35、D37：日付

にはなりません。

　それと「C31～C37に最大値を転記する」や「D31～D37に書式を設定する」を
For column = 2 To 32
によって31回も繰り返すなどという無駄な事をする必要などありません。

　ですから、例えどうしても
For column = 2 To 32
を使った繰り返し処理によって最大値を求めたいのだとしましても、質問者様が仰った

>現状は以下コード

では、御質問文に書かれた通りの結果を出す事は出来ませんから、次の様にされた方が良いと思います。

Sub 最大値の取得_繰返し処理版()

Dim row As Integer '変数rowを宣言
Dim column As Integer '変数columnを宣言
Dim max As Long '変数maxを宣言
Dim temp As Variant '変数tempを宣言
Dim maxday As Variant '変数maxdayを宣言

With Application
.ScreenUpdating = False '画面表示の更新停止
.Calculation = xlManual '計算モードを手動にする
End With

Range("C31:D38").ClearContents
For row = 0 To 3 '行番号のオフセット数rowが0～3の範囲で繰り返し処理を行う
max = 0 'maxに0を代入する
For column = 2 To 32 'columnが32まで繰り返し処理を行う
temp = Cells(row + 20, column).Value 'tempに値を代入する
If IsNumeric(temp) Then '値が数値の場合
If temp > max Then 'maxより大きい値の場合
max = temp 'maxに値を代入する
maxday = Cells(19, column).Value
End If 'If temp > max Then文の終了
End If 'If IsNumeric(temp) Then文の終了
Next column 'columnの値を増分する
If max > 0 Then
With Cells(row * 2 + 31, "C")
.Value = max '最大値を転記する
With .Offset(0, 1)
.Value = maxday '最大値に紐づく日付を入力する
.NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する
.HorizontalAlignment = xlCenter '横位置中央
.VerticalAlignment = xlCenter '縦位置中央
.WrapText = True '折り返して全体を表示する
.RowHeight = .RowHeight + .Font.Size * 1.5 '行の高さを調整する
End With
End With
End If 'If max > 0 Then文の終了
Next row 'rowの値を増分する

With Application
.Calculation = xlAutomatic '計算モードを自動にする
.ScreenUpdating = True '画面表示の更新再開
End With

End Sub

補足

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

ほぼ想定した動作になってきましたが、
恐れ入りますが、日付と曜日を表示するコードで追加質問させていただけないでしょうか。

> .NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する

この部分を改良中です。

11/1
(月)
のように日付の表示形式を変更したいのですが、
どのようにすればいいでしょうか。
セルのコピーをした際に、そのまま引っ張れるようにしたいと考えています。
.Value = maxday & vbCrLf & "(" & Format(maxday, "aaa") & ")"　'改良中

回答No.2

keithin

そんなにムズカシく考えず今のアイデアをそのまま延長で、単純に「max値」を更新したらその日付を取得するだけでも十分です。

sub macro1()
　dim r as long
　dim c as long
　dim rr as long
　dim res as long

　for r = 20 to 23
　　rr = (r - 20 ) * 2 + 31
　　res = 0
　　for c = 2 to 32
　　　if cells(r, c).value > res then
　　　’更新したら転記する
　　　　res = cells(r, c).value
　　　　cells(rr, "C").value = res　’値と
　　　　cells(rr, "D").value = cells(19, c).value’日付
　　　end if
　　next c
　next r
end sub

言わずもがなですが、今の「作りたい表」では最大値が唯一であることが前提になっていますね。

またその前提によれば、わざわざマクロなど使わずとも
Ｃ３１：
=MAX(B20:AF20)
Ｄ３１：
=INDEX(B19:AF19,MATCH(C31,B20:AF20,0))
以下同文
のように関数で求めるのでも十分ですが。

回答No.1

kagakusuki

For column = 2 To 32

を使わずとも、次の様にすれば良いのではないでしょうか。

Sub 最大値の取得()

Dim i As Long, c As Range, max As Long

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

Range("C31:D34").ClearContents
For i = 0 To 3
With Range("B20:AF20")
max = Application.WorksheetFunction.max(.Offset(i))
Set c = .Offset(i).Find(max, , xlValues, xlWhole)
End With
If Not c Is Nothing Then
Range("C31").Offset(i).Value = max
Range("D31").Offset(i).Value _
= Format(Cells(19, c.Column).Value, "m月d日" & vbCrLf & "aaaa")
End If
Next i

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

補足

すみません。現状は以下コードになりました。

Sub macro1()

Dim row As Integer '変数rowを宣言
Dim column As Integer '変数columnを宣言
Dim rrow As Integer '変数rrowを宣言
Dim max As Long '変数maxを宣言

For row = 20 To 23 'rowが23まで繰り返し処理を行う
rrow = (row - 20) * 2 + 32 'rrowに行番号を代入する
max = 0 'maxに0を代入する
For column = 2 To 32 'columnが32まで繰り返し処理を行う
If Cells(row, column).Value > max Then 'maxより大きい値の場合
max = Cells(row, column).Value 'maxに値を代入する
Cells(rrow - 1, "C").Value = max '最大値を転記する
Cells(rrow, "C").Value = Cells(19, column).Value '最大値に紐づく日付を入力する
Cells(rrow, "C").NumberFormatLocal = "m/d" & vbCrLf & "aaa" '日付の表示形式を変更する
With Cells(rrow, "C")
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
End With
'Cells(rrow, "C").Offset(-1, 0).Value = "aaa" '最大値に紐づく日付と曜日を入力する

End If 'If文の終了
Next column 'columnの値を増分する
Next row 'rowの値を増分する

End Sub

'Cells(rrow, "C").Value = Format(Cells(19, column).Value & vbCrLf & "aaa")
'MsgBox Format(Cells(19, column).Value & vbCrLf & "aaa")

部分部分で質問させてください。

>With Cells(rrow, "C")
> .HorizontalAlignment = xlRight
> .VerticalAlignment = xlBottom
> End With

C32, C34, C36, C38に

11/1
(月)

のように左詰で結果を入れたいと思っています。
どのようにすればよろしいでしょうか。