GBKEE

回復 10# luke
執行 [寫入Work]前須先執行 [Link] 確定工作表的超連結.

1. Sub Link()
   
2.     Dim D As Object, R As Integer, C As Range, A As Range, Ky As Variant
   
3.     Set D = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("sheet1")
   
5.         Set A = .[A:A].Find([J1], lookat:=xlWhole)
   
6.         If [J1] = "" Then Exit Sub
   
7.         For Each C In .Range(A, .[A65536].End(xlUp))
   
8.             If C & C.Offset(, 1) Like .[I3] & .[J3] Then
   
9.                 D(C.Value & D.Count) = C.Resize(, 2).Address(0, 0)
   
10.             End If
    
11.         Next
    
12.         [L:N].Clear
    
13.         If D.Count = 0 Then MsgBox "無符合資料": Exit Sub
    
14.         For Each Ky In D.keys
    
15.             R = R + 1
    
16.             .Cells(R, "L") = .Range(D(Ky)).Cells(1, 1)
    
17.             .Cells(R, "M") = .Range(D(Ky)).Cells(1, 2)
    
18.             .Hyperlinks.Add Anchor:=.Cells(R, "N"), Address:="", SubAddress:=D(Ky)
    
19.         Next
    
20.     End With
    
21.     Range("J3").Select
    
22. End Sub
    
23. Sub 寫入Work()
    
24.     Dim Rng(1 To 3) As Range, E As Variant, R As Range
    
25.     Set Rng(1) = Sheets("Work").UsedRange.Range("a:a")
    
26.     For Each E In Sheets("Sheet1").Hyperlinks                 '物件集合:工作表的超連結。
    
27.         Set Rng(2) = Sheets("Sheet1").Range(E.SubAddress)     '制定: 超連結的儲存格
    
28.         For Each R In Rng(1)
    
29.             If Rng(2).Cells(1) & Rng(2).Cells(1, 2) = R & R.Cells(1, 2) Then '與超連結儲存格的內容相同
    
30.                 Set Rng(3) = R.CurrentRegion                               '範圍只有AB兩欄
    
31.                 'CurrentRegion 屬性 傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
    
32.                 Rng(2).CurrentRegion.Copy                                    '複製:超連結儲存格的連續範圍
    
33.                 Rng(3)(1).Insert Shift:=xlDown                               '插入貼上:超連結儲存格的連續範圍
    
34.                 'Rng(3)(1) =>  Rng(3).Cells(1, 1)                            '範圍的第一個楚墫格
    
35.                 Set Rng(3) = Rng(3).Range("A1:C" & Rng(3).Rows.Count)        '多增加一欄保持資料的完整性 (C欄也要刪除)
    
36.                 Rng(3).Delete Shift:=xlUp                                    '刪除: 下方儲存格上移
    
37.                 Exit For
    
38.             End If
    
39.         Next
    
40.     Next
    
41.     Set Rng(1) = Sheets("Sheet1").[A:A].Find("END", lookat:=xlWhole)   '[SHEET1]A欄中尋找: "END"
    
42.     Set Rng(1) = Sheets("Sheet1").Range("A1:C" & Rng(1).Row)           '制定範圍: A欄到C欄 "END"的列號
    
43.     Rng(1).Copy Sheets("Work").Cells(Sheets("Work").Rows.Count, 1).End(xlUp)
    
44.     MsgBox "完成"
    
45. End Sub

複製代碼