| |
お返事ありがとうございます
コードは以下になります
Option Explicit
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
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)
Call pickUpOneLine(target)
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
これがすべてです
あまり良くないと思うので（会社的）通りすがりさんが見られたらこのコードは消させていただきます；；
小心者ですみません；；
お忙しい中大変申し訳ございません
相談できる相手もいなく、大変困っておりましたので
本当に有難い限りです
お返事いただけますと幸いです
よろしくお願いします
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
