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
> 日付の表示形式の分類を「日付(種類:*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日
以下で試してみてください。
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
お礼
バッチリでした。重ね重ねのご教示ありがとうございました。