Question

我有两本工作簿

Master Workbook 
Slave workbook

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

主要工作簿

C5 = 1234

然后我想在我的奴隶工作簿上查看这个数字的E列。

奴隶工作簿

Column E    Column F
1222        Beans
1234        Cheese

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

主要工作簿

C5 = 1234
C6: Cheese

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

如果奴隶工作簿已打开
如果工作簿文件名的最后7个字符是“Volumes”

无论将从属工作簿重命名为什么，最后的字符“卷”都将保留在文件名中，如下所示：

file1 16.01.17 volumes.xls
or
file1 19.01.17 volumes.xls

EDIT 这是我的代码：

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

vba参考工作簿如果激活，文件名的最后7个字符包含x？

1 个答案: