エクセルのマクロ（値を検索して別シートにコピー）

質問

エクセルで下記のマクロをご教示いただけるでしょうか。
1.Sheet1のアクティブセルの右に5つ、下に1つのセルを起点として下方向に6セル分をコピー　（例）Sheet1のアクティブセルがA2だとすると、F3～F8をコピー
2.Sheet1のアクティブセルの値（yy/mm/dd形式の日付）と同じ値のセルをSheet2のA列から検索し、該当セルの右に2つ分のセルに行列を入れ替えて値のみをペースト　（例）Sheet1のアクティブセル（A2）の値がSheet2のA4セルにあるとすると、Sheet2のC4に行列を入れ替えて値のみペースト
3.Sheet1のアクティブセルの値がSheet2のA列に2つ以上あれば、「同じ日付が複数あります。」というメッセージを表示

回答No.3

kkkkkm · ベストアンサー

No.2の追加です

Dim fRng As Range
を削除して
Dim c As Range
を追加してください。

また、
If IsDate(c.Value) = True Then
はいらないと思いますので(テスト時のものが残ってました)

For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp))
If IsDate(c.Value) = True Then
If c.Value = Selection.Value Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Exit Sub
End If
End If
Next

を以下に変更してください。

For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp))
If c.Value = Selection.Value Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Exit Sub
End If
Next

また、日付として同じでも見た目が同じもの以外は別物とする場合
Dim cnt As Long
を追加して

If WorksheetFunction.CountIf(Ws2.Range("A:A"), Selection.Value) > 1 Then
MsgBox "同じ日付が複数あります", vbInformation
Set Ws1 = Nothing
Set Ws2 = Nothing
Exit Sub
End If

を以下に変更して

For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp))
If c.Text = Selection.Text Then
cnt = cnt + 1
If cnt > 1 Then
MsgBox "同じ日付が複数あります", vbInformation
Set Ws1 = Nothing
Set Ws2 = Nothing
Exit Sub
End If
End If
Next

その下にある

If c.Value = Selection.Value Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Exit Sub
End If

を以下に変更してください。

If c.Text = Selection.Text Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Exit Sub
End If

回答No.5

kkkkkm

> 数値を昇順でソートしてからコピーするにはどのような処理を加えればよいでしょうか？（コピーしてからソートでも手間が少ないほうで結構です）

元のSheet1のデータをソートする場合。

最後の方に

Tmp = Selection.Offset(1, 5).Resize(6, 1).Value

というところがありますので
その前にソートのコードを追加します。

↓追加
Selection.Offset(1, 5).Resize(6, 1).Sort _
Key1:=Selection.Offset(1, 5), Order1:=xlAscending
↑追加ここまで
↓既存のコード
Tmp = Selection.Offset(1, 5).Resize(6, 1).Value

転記後のSheet2のデータをソートする場合。

上記コードの下にある

If c.Value = Selection.Value Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Exit Sub
End If

の部分を以下に変更してください。

If c.Value = Selection.Value Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
'↓追加
c.Offset(0, 2).Resize(1, 6).Sort _
Key1:=c.Offset(0, 2), Order1:=xlAscending, Orientation:=xlLeftToRight
'↑追加ここまで
Exit Sub
End If

お礼

バッチリでした。重ね重ねのご教示ありがとうございました。

回答No.4

kkkkkm

No.2の訂正

Findだと同じ形式じゃないと駄目みたいですね。

は

Findだと（種類：*2012/3/14）以外だと駄目だったり(種類：*2012年3月14日)の場合いけたり駄目だったりで不安定な感じです。

お礼

ありがとうございます。私の仕様にいろんなメッセージを追加していただき、何が原因で正しく動作しないのか一目瞭然です。素晴らしいです。

補足

追加質問で恐縮です。1の「アクティブセルの右に5つ、下に1つのセルを起点として下方向に6セル分」の数値を昇順でソートしてからコピーするにはどのような処理を加えればよいでしょうか？（コピーしてからソートでも手間が少ないほうで結構です）

回答No.2

kkkkkm

> 日付の表示形式の分類を「日付（種類：*2012/3/14）」にするとうまくいきますが、「日付（種類：2012/3/14）」やユーザー定義の「YY/MM/DD」にすると、「該当するデータがありません」というメッセージが出ます。

Findだと同じ形式じゃないと駄目みたいですね。
Findをやめて

'Set fRng = Ws2.Range("A:A").Find(What:=Selection.Text)
'If Not fRng Is Nothing Then
' fRng.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
'Else
' MsgBox "該当するデータがありません", vbInformation
'End If

の部分を

For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp))
If IsDate(c.Value) = True Then
If c.Value = Selection.Value Then
c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Exit Sub
End If
End If
Next

MsgBox "該当するデータがありません", vbInformation

に変更してみてください。
形式に関わらず以下の場合でも同じ日と認識すると思います。

2022/1/10を
形式で以下のようにしたもの
22/1/10
2022年1月10日
2022年1月
1月10日

回答No.1

kkkkkm

以下で試してみてください。

Sub Test()
Dim Tmp As Variant
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim fRng As Range

Set Ws1 = Sheets("Sheet1")

If ActiveSheet.Name <> Ws1.Name Then
MsgBox Ws1.Name & "以外を選択して実行できません", vbInformation
Set Ws1 = Nothing
Exit Sub
End If

If Selection.Count > 1 Then
MsgBox "複数のセルを選択して実行できません", vbInformation
Set Ws1 = Nothing
Exit Sub
End If

If Selection.Value = "" Then
MsgBox "セルに値がありません", vbInformation
Set Ws1 = Nothing
Exit Sub
End If

Set Ws2 = Sheets("Sheet2")

If WorksheetFunction.CountIf(Ws2.Range("A:A"), Selection.Value) > 1 Then
MsgBox "同じ日付が複数あります", vbInformation
Set Ws1 = Nothing
Set Ws2 = Nothing
Exit Sub
End If

Tmp = Selection.Offset(1, 5).Resize(6, 1).Value

Set fRng = Ws2.Range("A:A").Find(What:=Selection.Value, LookIn:=xlValues)
If Not fRng Is Nothing Then
fRng.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp)
Else
MsgBox "該当するデータがありません", vbInformation
End If

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

補足

ご教示ありがとうございます。追加の質問があります。私の環境（Windows11）では日付の表示形式の分類を「日付（種類：*2012/3/14）」にするとうまくいきますが、「日付（種類：2012/3/14）」やユーザー定義の「YY/MM/DD」にすると、「該当するデータがありません」というメッセージが出ます。この点に関して詳解していただけると幸いです。