| |
Bookを開いたときに別シート(検索2)に保存しておく。
何回か適当に検索した後、F1やG1をクリック。
Option Explicit
Private myReDO As Variant
Private Sub Worksheet_Change(ByVal target As Range)
Const wshInfoName As String = "結果"
Const CriteriaScope As String = "A1:D5"
Dim originalWord
If target.Address(0, 0) <> "A2" Then Exit Sub
If target.Value = "" Then Exit Sub
Application.ScreenUpdating = False
myRedo = Target.Value
originalWord = Range("A1:H2").Value
Application.EnableEvents = False
Range("A1:D2,A3:T1506").ClearContents
Range("A1:B1").Value = Sheets(wshInfoName).Range("A1:B1").Value
Range("C1").Value = Sheets(wshInfoName).Range("D1").Value
Range("A2,B3,C4").Value = "*" & originalWord(2, 1) & "*"
Range("A2,B3,C4,D5").Value = "*" & originalWord(2, 1) & "*"
Sheets(wshInfoName).Columns("A:T").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("検索").Range(CriteriaScope), CopyToRange:=Range("A6"), Unique:=False
Range("A1:H2").Value = originalWord
Range("A3:D5").ClearContents
Columns("A:T").EntireColumn.AutoFit
ActiveWindow.FreezePanes = False
Rows("7:7").Select
ActiveWindow.FreezePanes = True
Application.GoTo Reference:="R6C1"
Rows("7:1500").RowHeight = 18.75
If Range("A7").Value <> "" And Range("A8").Value = "" Then
Call pickUpOneLine(Range("A7"))
End If
Range("A2").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub disappear()
Me.Pictures.Delete
End Sub
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If target.Address = "$F$1" Then '一つ前
If Len(myReDO) > 0 Then '変数が空でなかったら
Me.Range("A2").Value = myReDO 'A2に変数の値を入れる。
'Changeイベントが働き、検索。
End If
ElseIf target.Address = "$G$1" Then
Sheets("検索2").Cells.Copy Me.Cells(1)
Else
Call pickUpOneLine(target)
End If
End Sub
Private Sub pickUpOneLine(ByVal target As Range)
Dim rngToReact As Range
Dim rngForPhoto As Range
Dim cel As Range
Dim NN As Long
Dim strPath As String
Dim Fname As String
disappear
If target.Count > 1 Then Exit Sub
If target.Value = "" Then Exit Sub
Set rngToReact = Range("A7:J1506")
Set rngForPhoto = Range("C4:G5")
If Not Intersect(target, rngToReact) Is Nothing Then
Application.EnableEvents = False
Range("A3:H3").Value = target.EntireRow.Range("A1:H1").Value
Range("A4:G4").Value = target.EntireRow.Range("I1:O1").Value
Range("C5:F5").Value = target.EntireRow.Range("P1:T1").Value
Columns("A:T").EntireColumn.AutoFit
strPath = ThisWorkbook.Path & "\" & Range("A4").Value _
& IIf(Range("B4").Value = "", "\", "\" & Range("B4").Value & "\")
NN = 1
For Each cel In rngForPhoto
If cel.Value <> "" Then
cel.Value = strPath & cel.Value
cel.NumberFormatLocal = ";;;" & """画像" & NN & """"
NN = NN + 1
End If
Next
rngForPhoto.Font.Underline = xlUnderlineStyleSingle
rngForPhoto.Font.ColorIndex = 5
Application.EnableEvents = True
ElseIf Not Intersect(target, rngForPhoto) Is Nothing Then
Call photoShow(target)
End If
End Sub
Private Sub photoShow(ByVal target As Range)
Dim OrgWidth As Double
Dim OrgHeight As Double
Dim ratio As Double
On Error GoTo photoNone
Me.Pictures.Insert (target.Value)
On Error GoTo 0
With Me.Pictures(Me.Pictures.Count)
OrgWidth = .Width
OrgHeight = .Height
.Height = Range("C7:C20").Height
.Width = OrgWidth * .Height / OrgHeight
.Top = Cells(7, 1).Top
.Left = Cells(7, 3).Left
.OnAction = Me.CodeName & ".disappear"
End With
Exit Sub
photoNone:
MsgBox "対応画像なし"
End Sub
'****ThisworkBookモジュール****
Private Sub Workbook_Open()
Sheets("検索2").Cells.Copy Sheets("検索？").Cells(1) 'シート名は適当
End Sub
|
|
とおりすぎ
- 11/8/26(金) 16:34 -
