Excel VBA 入力規則
入力規則を利用して、３つのセルを連携させることを考えていますが、
不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ad As String
Dim ma As Range
Dim ma2 As Range
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim r1 As Range
Dim m As Long
Dim m2 As Long
Application.EnableEvents = False
If Target = "" Then
Range("F7").Validation.Delete
Range("F7") = ""
If Target.Address(0, 0) = "B7" Then
Range("D7").Validation.Delete
Range("D7") = ""
End If
GoTo EXIT_SUB
End If
With Worksheets("Sheet1")
ad = "A4"
Set r = .Range(ad)
Set ma = r.MergeArea
Set r1 = r.Offset(0, 1)
m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0)
Set r2 = .Cells(r.Row + m - 1, r1.Column)
Set ma2 = r2.MergeArea
If Target.Address(0, 0) = "B7" Then
If ma.MergeCells Then
setValiS Target.Offset(0, 2), r2
Range("F7").Validation.Delete
Target.Offset(0, 2) = ""
Target.Offset(0, 4) = ""
Else
MsgBox "A列が連結されていません。"
End If
ElseIf Target.Address(0, 0) = "D7" Then
Set r3 = r2.Offset(0, 1)
m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0)
setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column)
Target.Offset(0, 2) = ""
End If
End With
EXIT_SUB:
Application.EnableEvents = True
End Sub
Sub setVali2()
Dim tc As Range
Dim c As Range
Set tc = Worksheets("登録").Range("D3")
Set c = Worksheets("Sheet1").Range("C3")
setValiS tc, c
End Sub
Sub setValiS(tc As Range, c As Range)
Dim ss As String
Debug.Print tc.Address, c.Address
ss = getChildren(c)
If ss > "" Then
With tc.Validation
.Delete
.Add Type:=xlValidateList, Formula1:=getChildren(c)
End With
End If
Worksheets("登録").Activate
End Sub
Function getChildren(c As Range)
Dim c1 As Range
Dim ss As String
Dim s1 As String
Worksheets("Sheet1").Activate
ss = ""
For Each c1 In c.MergeArea
s1 = c1.Offset(0, 1)
If s1 <> "" Then ss = ss & "," & s1
Next c1
If ss <> "" Then
ss = Mid(ss, 2)
Else
MsgBox "データがありません！"
End If
getChildren = ss
End Function
Sub Outline()
Dim CheckRow As Long
Dim Moji As String
Dim TopRow As Long
Dim EndRow As Long
With ActiveSheet
.Range("A2").ClearOutline
.Outline.SummaryRow = xlAbove
CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row
CheckRow = CheckRow0
Do
If Moji = "" Then
Moji = .Cells(CheckRow, 1).Value
EndRow = CheckRow
ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then
TopRow = CheckRow
If TopRow = 1 Then
.Rows(TopRow + 1 & ":" & EndRow).Rows.Group
Exit Do
End If
Else
.Rows(TopRow + 1 & ":" & EndRow).Rows.Group
CheckRow = CheckRow + 1
Moji = ""
End If
CheckRow = CheckRow - 1
Loop Until CheckRow = 1
.Rows(CheckRow + 1 & ":" & EndRow).Rows.Group
.Outline.ShowLevels RowLevels:=1
ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)"
End With
End Sub
Function yy_mm(d As Date)
yy_mm = Format(d, "yy/mm")
End Function
お礼
myPath = ActiveWorkbook.Path & "\" & Worksheets("Sheet1").Range("B2") & "\" に変更することでできました。 ありがとうございました。
補足
ありがとうございます。 Set w = Worksheets("部署")を追加し、Set w = ActiveSheetを削除することで出来ました。 myPath = ActiveWorkbook.Path & "\" & Worksheets("Sheet1").Range("B2") の方はtestファイルの中に保存してなく、同じ場所に2〇〇.xlsxとなってしまいます。