| |
シート２のシートモジュールへ、以下のマクロを入れてみて下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Nm As Long, xR As Long, i As Long
Dim CkC As Variant
Dim MyR As Range, C As Range
With Target
If .Address <> "$A$1" Then Exit Sub
If .Count > 1 Then Exit Sub
If IsEmpty(.Value) Then Exit Sub
If Not IsNumeric(.Value) Then Exit Sub
If .Value < 1 Or .Value > 31 Then Exit Sub
Nm = .Value
End With
With Worksheets("Sheet1")
CkC = Application.Match(Nm, .Rows(1), 0)
If IsError(CkC) Then
MsgBox "その番号は見つかりません", 48: Exit Sub
End If
xR = .Range("A65536").End(xlUp).Row
Set MyR = .Range(.Cells(3, CkC), .Cells(xR, CkC))
If WorksheetFunction.CountBlank(MyR) = 0 Then
MsgBox "空白の科目はありません", 48
Set MyR = Nothing: Exit Sub
End If
Set MyR = _
Intersect(MyR.SpecialCells(4).EntireRow, .Range("B:B"))
End With
Application.EnableEvents = False
Rows("20:20").ClearContents
For Each C In MyR
i = i + 1: Cells(20, i).Value = C.Value
Next
Application.EnableEvents = True: Set MyR = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
