vba引用工作簿，如果活动并且文件名的最后7个字符包含x

Question

我有两本工作簿

Master Workbook 
Slave workbook

在我的主工作簿中的工作表更改事件中，如果用户在单元格C5中输入一个数字，如下所示：

主工作簿

C5 = 1234

然后我想在我的从属工作簿的E列中查找这个数字。

从属工作簿

Column E    Column F
1222        Beans
1234        Cheese

如果找到，我想从从属工作簿的列F中获取相应的值，并将其放入主工作簿的单元格C6中。

主工作簿

C5 = 1234
C6: Cheese

另一个问题是我的从属工作簿会不时更改名称，这意味着我不能用绝对引用来引用它。相反，我想根据两个条件引用从属工作簿：

1. 如果从属工作簿处于打开状态
2. 如果工作簿文件名的最后7个字符是"卷">

无论从属工作簿重命名为什么，最后一个字符"volumes"都将保留在文件名中，如下所示：

file1 16.01.17 volumes.xls
or
file1 19.01.17 volumes.xls

编辑这是我的代码：

Private Sub Worksheet_SelectionChange(ByVal Target as Range) 
Dim Dic As Object, key As Variant, oCell As Range, i&
Dim w1 As Worksheet, w2 As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
Set w1 = ThisWorkbook.Sheets(1)
Set w2 = Workbooks("workbookB.xlsm").Sheets("Sheet1")
i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row
For Each oCell In w1.Range("C5")
If Not Dic.exists(oCell.Value) Then
Dic.Add oCell.Value, oCell.Offset(1, 0).Value
End If
Next
i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row
For Each oCell In w2.Range("E4:E" & i)
For Each key In Dic
If oCell.Value = key Then
oCell.Offset(, 1).Value = Dic(key)
End If
Next
Next
End Sub

我是vba的新手，所以不确定我的代码是否正确，但请有人告诉我如何让它做我需要的事情？

感谢

Answer 1

尝试下面的编辑代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Dic As Object, key As Variant, oCell As Range, i As Long
Dim w1 As Worksheet, w2 As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
Set w1 = ThisWorkbook.Sheets(1)
'With w1
'   i = .Cells(.Rows.Count, "D").End(xlUp).Row
'End With
For Each oCell In w1.Range("C5")
If Not Dic.exists(oCell.Value) Then
Dic.Add oCell.Value, oCell.Offset(, -3).Value
End If
Next
Dim wbInd   As Integer
Dim wb2 As Workbook
For wbInd = 1 To Workbooks.Count ' <-- loop through all open workbooks
If Workbooks(wbInd).Name Like "*volumes.xlsx" Then '<-- check if workbook name contains "volumes"
Set wb2 = Workbooks(wbInd)
Exit For
End If
Next wbInd
Set w2 = wb2.Sheets("Sheet1")
With w2
i = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For Each oCell In w2.Range("A2:A" & i)
For Each key In Dic
If oCell.Value = key Then
oCell.Offset(, 2).Value = Dic(key)
End If
Next
Next
End Sub

---

编辑1：将代码移动到Worksheet_Change事件，并且只有在单元格"C5"中的值被修改时才运行代码。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dic As Object, key As Variant, oCell As Range, i As Long
Dim w1 As Worksheet, w2 As Worksheet
If Not Intersect(Target, Range("C5")) Is Nothing Then ' <-- run this code only if a value in cell C5 has change
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
If Not Dic.exists(Target.Value) Then
Dic.Add Target.Value, Target.Offset(1, 0).Value
End If
Dim wbInd   As Integer
Dim wb2 As Workbook
For wbInd = 1 To Workbooks.Count ' <-- loop through all open workbooks
If Workbooks(wbInd).Name Like "*volumes.xlsx" Then '<-- check if workbook name contains "volumes"
Set wb2 = Workbooks(wbInd)
Exit For
End If
Next wbInd
Set w2 = wb2.Sheets("Sheet1")
With w2
i = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
For Each oCell In w2.Range("E2:E" & i)
For Each key In Dic
If oCell.Value = key Then
Target.Offset(1, 0).Value = oCell.Offset(0, 1) '<-- put the the value in column F (offset 1 column) to cell C6 (one row offset)
End If
Next
Next
End If
Application.EnableEvents = True
End Sub