- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 10# luke
執行 [寫入Work]前須先執行 [Link] 確定工作表的超連結.- Sub Link()
- Dim D As Object, R As Integer, C As Range, A As Range, Ky As Variant
- Set D = CreateObject("Scripting.Dictionary")
- With Sheets("sheet1")
- Set A = .[A:A].Find([J1], lookat:=xlWhole)
- If [J1] = "" Then Exit Sub
- For Each C In .Range(A, .[A65536].End(xlUp))
- If C & C.Offset(, 1) Like .[I3] & .[J3] Then
- D(C.Value & D.Count) = C.Resize(, 2).Address(0, 0)
- End If
- Next
- [L:N].Clear
- If D.Count = 0 Then MsgBox "無符合資料": Exit Sub
- For Each Ky In D.keys
- R = R + 1
- .Cells(R, "L") = .Range(D(Ky)).Cells(1, 1)
- .Cells(R, "M") = .Range(D(Ky)).Cells(1, 2)
- .Hyperlinks.Add Anchor:=.Cells(R, "N"), Address:="", SubAddress:=D(Ky)
- Next
- End With
- Range("J3").Select
- End Sub
- Sub 寫入Work()
- Dim Rng(1 To 3) As Range, E As Variant, R As Range
- Set Rng(1) = Sheets("Work").UsedRange.Range("a:a")
- For Each E In Sheets("Sheet1").Hyperlinks '物件集合:工作表的超連結。
- Set Rng(2) = Sheets("Sheet1").Range(E.SubAddress) '制定: 超連結的儲存格
- For Each R In Rng(1)
- If Rng(2).Cells(1) & Rng(2).Cells(1, 2) = R & R.Cells(1, 2) Then '與超連結儲存格的內容相同
- Set Rng(3) = R.CurrentRegion '範圍只有AB兩欄
- 'CurrentRegion 屬性 傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
- Rng(2).CurrentRegion.Copy '複製:超連結儲存格的連續範圍
- Rng(3)(1).Insert Shift:=xlDown '插入貼上:超連結儲存格的連續範圍
- 'Rng(3)(1) => Rng(3).Cells(1, 1) '範圍的第一個楚墫格
- Set Rng(3) = Rng(3).Range("A1:C" & Rng(3).Rows.Count) '多增加一欄保持資料的完整性 (C欄也要刪除)
- Rng(3).Delete Shift:=xlUp '刪除: 下方儲存格上移
- Exit For
- End If
- Next
- Next
- Set Rng(1) = Sheets("Sheet1").[A:A].Find("END", lookat:=xlWhole) '[SHEET1]A欄中尋找: "END"
- Set Rng(1) = Sheets("Sheet1").Range("A1:C" & Rng(1).Row) '制定範圍: A欄到C欄 "END"的列號
- Rng(1).Copy Sheets("Work").Cells(Sheets("Work").Rows.Count, 1).End(xlUp)
- MsgBox "完成"
- End Sub
|
|
發表於 2013-5-29 09:06
| 