拜託幫幫忙
VBA HYPERLINK這個程式卡很久了,煩請大家幫幫忙,問題如下
想做一個超連結,如果SHEET1的M,O,Q…..欄的日期是紅色的, 點此日期欄位就會自動連結到SHEET2的C,D,E……的欄位去,但要符合SHEET1的D:D和M1,W1….及M2,O2,Q2…這三個要件
資料網址: https://www.sendspace.com/file/1v7l3k
以上,
謝謝,感恩
沒殼的螃蟹 wrote:
對不起,我以為Mobil01...(恕刪)
其實就是第一頁的"預計完成日期"的欄位日期變紅之後,要連結到第2頁的"原因&解決對策",但要符合"廠內料號",EVT.....,線路設計......
沒殼的螃蟹 wrote:
對,就是你說的第一點...(恕刪)
[點擊下載]
大概這樣?!我只有加連結的部分，其他功能要在用其他方式~
btw...因為Sheet2是沒有資料的，所以我用廠內料號搜尋。
主要功能為找到工作表1 B欄有紅色底，就會去搜尋工作表2相對應的資料，如果找到資料就會在工作表1建立超連結過去工作表2的對應欄位，但是沒找到就沒反應...可以自己加動作進去，例如沒找到要做提醒之類的。
另外，工作表1底色不是紅色的，他會清掉超連結...也可以自己改
這應該大致上符合你的需求，自己套用一下就可以了
程式碼....我沒打註解
小小尉 wrote:
工作表1建立超連結過去工作表2的對應欄位...(恕刪)
您的範例，改用SelectionChange的方式，代替超連結，好像也合用
這樣就不用特別做一個按鈕了，請參考
'
'程式碼放在工作表1
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Dim check As Range
If Target.Column = 2 And Target.Interior.Color = vbRed Then
Set check = Worksheets("工作表2").Columns("C").Find(What:=Target.Value)
If check Is Nothing Then
Debug.Print Target.Value, "nothing"
Else
With Worksheets("工作表2")
.Select
.Range(check.Address).Select
End With
End If
End If
Set check = Nothing
End Sub
20191117 補充另一種寫法
突然想到，用popup視窗看資料比較方便
雖然用註解比較簡單，但做出一個popup視窗，比較有趣
，請參考
'
'程式碼放在工作表1
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static h As Boolean
If h = True Then
Worksheets("工作表1").Shapes("arrow").Delete
h = False
End If
On Error Resume Next
Dim check As Range, HighLight As Shape, Data As String, x As Integer, y As Integer
If Target.Column = 2 And Target.Interior.Color = vbRed And Target.Count = 1 Then
Set check = Worksheets("工作表2").Columns("a").Find(What:=Target.Value)
If check Is Nothing Then
Data = "error"
Else
Data = Worksheets("工作表2").Cells(check.Row, 2).Value
End If
x = Target.Left + 70
If Target.Top < 100 Then y = 5 Else y = Target.Top - 100
If Data <> "" Then
Set HighLight = Worksheets("工作表1").Shapes.AddShape(msoShapeCloudCallout, x, y, 160, 100)
h = True
With HighLight
.Fill.ForeColor.RGB = vbGreen
.TextFrame.Characters.Text = Data
.TextFrame.Characters.Font.Color = vbRed
.TextFrame.Characters.Font.Bold = msoTrue
.TextFrame.Characters.Font.Size = 32
.Adjustments.Item(1) = -0.55
If y = 5 Then .Adjustments.Item(2) = Choose(Target.Row, -0.419, -0.269, -0.119, 0.055, 0.199, 0.367, 0.523)
.Name = "arrow"
End With
End If
End If
Set check = Nothing
End Sub
[點擊下載]
內文搜尋
從 APP 打開
X