麻辣家族討論版版 - Powered by Discuz! Board

標題: 請問要如何自動在每一個地址上加入Google地圖連結，且字型顏色皆不會變，謝謝您! [打印本頁]

作者: peter460191 時間: 2013-6-6 15:42 標題: 請問要如何自動在每一個地址上加入Google地圖連結，且字型顏色皆不會變，謝謝您!

請問要如何自動在(A2~A10儲存格)每一個地址上加入Google地圖連結，且字型顏色皆不會變

[attach]15185[/attach]
[attach]15186[/attach]

作者: stillfish00 時間: 2013-6-6 20:55

回復 1# peter460191
試試看

Sub TEST()
Dim r As Long, x
With Sheets("Sheet1")
r = .Cells(.Rows.Count, "A").End(xlUp).Row
If r > 1 Then
For Each x In .Range("A2:A" & r)
.Hyperlinks.Add Anchor:=x, Address:="http://maps.google.com.tw/maps?q=" & x.Value
Next
.Range("A2:A" & r).Style = "Normal"
End If
End With
End Sub

複製代碼

作者: peter460191 時間: 2013-6-7 11:51

回復 2# stillfish00

感謝 stillfish00 的指導，已經可以，會好好研究，非常謝謝您!

作者: peter460191 時間: 2013-6-7 12:06

回復 2# stillfish00

請問 stillfish00
若我要變更地址位置及數量要如何改程式，我試了好久都未能成功，請幫忙教導，感激不盡，謝謝您!

作者: c_c_lai 時間: 2013-6-7 13:08

回復 stillfish00

請問 stillfish00
若我要變更地址位置及數量要如何改程式，我試了好久都未 ...
peter460191 發表於 2013-6-7 12:06

你是指這個嗎？

' 請放置在 "工作表1" 程式區內。
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
.Hyperlinks.Add Anchor:=Target, Address:="http://maps.google.com.tw/maps?q=" & Target
.Style = "Normal"
End With
End Sub

複製代碼

作者: stillfish00 時間: 2013-6-7 13:23

回復 4# peter460191
2# 地址的位置是抓A2到A欄最後一筆
如果你要明確指定區域，改成下面這樣就是指定A2到A10

Sub TEST()
Dim x
With Sheets("Sheet1").Range("A2:A10")
For Each x In .Cells
.Parent.Hyperlinks.Add Anchor:=x, Address:="http://maps.google.com.tw/maps?q=" & x.Value
Next
.Style = "Normal"
End With
End Sub

複製代碼

作者: peter460191 時間: 2013-6-7 13:40

回復 5# c_c_lai

感謝 c_c_lai 您的指導，有試過了，但有的可以有的不行，問題是出在那裡，謝謝您!

作者: peter460191 時間: 2013-6-7 13:46

回復 6# stillfish00

感謝stillfish00 指導，我再研究試試看

作者: peter460191 時間: 2013-6-10 12:53

回復 6# stillfish00

請問 stillfish00
若儲存格內的地址會隨機變動，但超連結只會記住第一個，請問有辦法隨儲存格內的地址變動，而地圖超連結也立即跟著變動嗎?
謝謝您!

作者: ML089 時間: 2013-6-10 14:01

回復 7# peter460191

我測試10幾筆都可以
要注意，程式筆需放在該工作表程式區

作者: stillfish00 時間: 2013-6-10 14:14

回復 9# peter460191

隨儲存格內的地址變動，而地圖超連結也立即跟著變動嗎?

這樣就是和5#一樣，寫在 Change 事件中，
稍微改了一下，若還是不行請上傳附件。

' 請放置在 "工作表1" 程式區內。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x, addrChange
Application.EnableEvents = False
Application.ScreenUpdating = False
Set addrChange = Intersect(Target, Range("A2:A10"))
If Not addrChange Is Nothing Then
For Each x In addrChange
If x.Value <> "" Then
Hyperlinks.Add Anchor:=x, Address:="http://maps.google.com.tw/maps?q=" & x.Value
x.Style = "Normal"
End If
Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

複製代碼

作者: peter460191 時間: 2013-6-11 09:10

回復 10# ML089

謝謝 ML089，我再試試看!

作者: peter460191 時間: 2013-6-11 09:15

回復 11# stillfish00

謝謝 stillfish00 指導，我再研究看看，若不行再向您請教，
另外再向您請教一個問題，檔案的地址數量太多(約400個)，及又有其他的矩陣及VBA程式，會不會影響執行結果?

作者: stillfish00 時間: 2013-6-11 09:55

回復 13# peter460191
執行結果你可以自行嘗試比較看看就知道了。
至於執行效率會不會影響，這要看你的地址是如何"隨機生成"，
除非地址內容常常會400個、400個變動，又或者
其他VBA程式中常常去變動那些地址，
否則應該影響不大。

當然，自行備分後嘗試比較看看是最清楚的。

作者: peter460191 時間: 2013-6-11 11:16

回復 14# stillfish00

了解了!
謝謝您!
我再試試看。

作者: av8d 時間: 2016-1-20 17:28

回復 14# stillfish00

老師，現在好像不能用了，地址會變成亂碼。

作者: stillfish00 時間: 2016-1-20 18:58

回復 16# av8d
加一function

Function encodeURL(str As String)
With CreateObject("ScriptControl")
.Language = "JScript"
.AddCode "function encode(str) {return encodeURIComponent(str);}"
encodeURL = .Run("encode", str)
End With
End Function

複製代碼

9樓改為
Hyperlinks.Add Anchor:=x, Address:="http://maps.google.com.tw/maps?q=" & encodeURL(x.Value)

這樣試試

作者: av8d 時間: 2016-1-20 19:31

回復 17# stillfish00

可以了~謝謝老師~如果老師還有空~是否可以解答一下這題
http://forum.twbts.com/viewthrea ... ighlight=%A6a%B9%CF

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)