| |
手入力したブック名などは、タイプミスする懸念がありますから、
できるだけ確実な方法を考えます。こんなマクロでどうでしょーか ?
以下の全てを標準モジュールの先頭から入れて下さい。
Set_MyLinkを実行したとき、InputBoxが２回出るのでリンク元・先の
セルを指定します。次にリンク元ブックを選びます。
するとA1セルのあたりにコンボボックスが出ますので、シート名を選んで下さい。
Private MyF As String, Ad1 As String, Ad2 As String
Sub Set_MyLink()
Dim LkR As Range, MyR As Range
Dim TbN As String, SAry() As String
Dim DB As DAO.Database, Tbl As DAO.TableDef
Dim i As Integer
On Error GoTo ELine
With Application
Do
Set LkR = Nothing
Set LkR = .InputBox("リンク 元 の" & _
"セルを一つ選択して下さい", Type:=8)
Loop While LkR.Count > 1
Set MyR = .InputBox("リンク 先 の" & _
"セル範囲を選択して下さい", Type:=8)
MyF = .GetOpenFilename("エクセルブック(*.xls),*.xls", _
, "リンク元のブックを選択して下さい")
If MyF = "False" Then GoTo ELine
End With
On Error GoTo 0
Ad1 = LkR.Address(0, 0): Ad2 = MyR.Address
ReDim SAry(0): SAry(0) = "[シートを選択]"
Set DB = DBEngine.Workspaces(0) _
.OpenDatabase(MyF, False, True, "Excel 8.0;HDR=NO")
For Each Tbl In DB.TableDefs
TbN = Left$(Tbl.Name, InStr(1, Tbl.Name, "$") - 1)
If IsError(Application.Match(TbN, SAry, 0)) Then
i = i + 1: ReDim Preserve SAry(i)
SAry(i) = TbN
End If
Next
With ActiveSheet.DropDowns.Add(0.1, 0.1, 100, 15)
.List = SAry()
.OnAction = "Go_Link"
.ListIndex = 1
End With
DB.Close: Set DB = Nothing: Erase SAry
ELine:
Set LkR = Nothing: Set MyR = Nothing
End Sub
Sub Go_Link()
Dim x As Variant
Dim Snm As String, LkS As String
x = Application.Caller
If VarType(x) <> 8 Then Exit Sub
With ActiveSheet.DropDowns(x)
If .ListIndex < 2 Then Exit Sub
Snm = .List(.ListIndex)
.Delete
End With
LkS = "='" & Replace(MyF, Dir(MyF), "[" & Dir(MyF) & "]") & _
Snm & "'!" & Ad1
Range(Ad2).Formula = LkS
End Sub
|
|
Kein
- 07/5/22(火) 18:04 -
