| |
↓これを全て、表のあるシートのシートモジュールへ、先頭から入れて下さい。
Private MyLst As String
Private Sh As Worksheet
Private Sub Worksheet_Activate()
Dim Cnt As Long
With WorksheetFunction
Cnt = .CountA(Range("A:A"))
Select Case Cnt
Case 0: MyLst = "": Exit Sub
Case 1: MyLst = Range("A:A").SpecialCells(2).Address
Case Else
MyLst = Range("A2", Range("A65536").End(xlUp)).Address
End Select
End With
If MyLst <> "" Then
On Error Resume Next
With Range("A1").Validation
.Delete
.Add xlValidateList, , xlBetween, "=" & MyLst
.InCellDropdown = True
End With
On Error GoTo 0
End If
Set Sh = ActiveSheet
Application.Goto Range("A1"), True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim GetN As String
Dim Ck As Variant
Dim MyR As Range
Dim Wp As Single, Hp As Single
With Target
If .Count > 1 Then Exit Sub
If .Address <> "$A$1" Then Exit Sub
If IsEmpty(.Value) Then Exit Sub
If MyLst = "" Then Exit Sub
If IsNumeric(.Value) Then Exit Sub
GetN = .Text
Application.EnableEvents = False
.Value = Empty
End With
Ck = Application.Match(GetN, Range("A:A"), 0)
If IsError(Ck) Then
MsgBox "その氏名は見つかりません", 48: Exit Sub
End If
With Range("A1", Range("IV1").End(xlToLeft))
Set MyR = Union(.Cells, Cells(Ck, 1).Resize(, .Count))
End With
With ActiveWindow.VisibleRange
With .Resize(.Rows.Count - 2, .Columns.Count - 2)
Wp = .Width: Hp = .Height
End With
End With
With ActiveSheet.ChartObjects
If .Count > 0 Then .Delete
With .Add(0.1, 0.1, Wp, Hp).Chart
.SetSourceData MyR, xlRows
.ChartType = xlColumnClustered
.HasLegend = False
.HasTitle = True
.ChartTitle.Text = GetN
End With
End With
Set MyR = Nothing: Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
If Not Sh Is Nothing Then
With Sh.ChartObjects
If .Count > 0 Then .Delete
End With
Set Sh = Nothing
End If
End Sub
いったん他のシートを開いてから当該シートに戻ると、A1セルに入力規則の
ドロップダウン矢印が出ます。リストから氏名を選択すると、ほぼ画面一杯に
グラフが挿入されます。別の人のグラフを見たいときは、また他のシートを
開いてから戻ればリセットされます。
|
|
Kein
- 07/5/21(月) 0:19 -
