Question

我有以下工作簿名为master：

Column I     Column K
1234         
1222         
1111

我还有一个名为slave的工作簿：

Column J        Column R
1234            Ambient
1222            Ambient
1111            Chiller

当用户在我的主工作簿的第I列中输入/粘贴数字时，我想检查我的从属工作簿中J列中是否存在相同的数字。

如果是，我想将相应的prodcut组从R列复制到K列中的主工作簿。

另一个问题是我的奴隶工作簿不时更改名称，但总是会包含“＆＃39;仓库备忘录”这个词。像这样：

Food Depot Memo
Drinks Depot Memo 01-19
etc.

我试图通过检查文件名是否包含＆＃39; depot memo＆＃39;来尝试引用我的slave工作簿。

由于某种原因，这不起作用。请有人告诉我我哪里出错了吗？

代码：

Private Sub Worksheet_Change(ByVal Target As Range)
 Application.EnableEvents = True
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("I:I")) 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 "Depot Memo*" Then '<-- check if workbook name contains "volumes"
            Set wb2 = Workbooks(wbInd)
            Exit For
        End If
    Next wbInd

     On Error GoTo message
    Set w2 = wb2.Sheets(1)

    With w2
        i = .Cells(.Rows.Count, "J").End(xlUp).Row
    End With

    For Each oCell In w2.Range("J6:J" & i)
        For Each key In Dic
            If oCell.Value = key Then
                Target.Offset(0, 2).Value = oCell.Offset(0, 8) '<-- 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
Exit Sub

message:
Exit Sub
End Sub

编辑：

使用来自@ user3598756的建议代码，我遇到了这个问题：

如果用户复制并粘贴这些值，而不是键入它们，则正确的供应商编号与第I列中的项目编号不对应。

这显然不正确，因为每个不同的料号应该有不同的供应商编号。

Answer 1

“Depot Memo *”名称检查中的通配符应出现在文本的开头和结尾。这将检测工作簿名称是否包含“Depot Memo”之前和/或之后的任何文本。

If Workbooks(wbInd).Name Like "*Depot Memo*" Then

Answer 2

已修改以处理多个已更改的单元格

有一件事并不像你期望的那样有效：

Like "Depot Memo*

既不会检测到＆＃34; Food Depot Memo＆＃34;也不是＆＃34;饮料仓库备忘录01-19＆＃34;

，而你必须使用

Like "*Depot Memo*"

此外：

不需要任何Dictionary对象
您不需要使用For Each oCell In w2.Range("J6:J" & i)进行迭代

所以我要对您的代码进行以下重构：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oCell As Range, targetCell As Range
    Dim ws2 As Worksheet

    If Not Intersect(Target, Range("I:I")) Is Nothing Then ' <-- run this code only if a value in column I has changed
        If Not GetWb("Depot Memo", ws2) Then Exit Sub

        With ws2
            For Each targetCell In Target
                Set oCell = .Range("J1", .Cells(.Rows.count, "J").End(xlUp)).Find(what:=targetCell.Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not oCell Is Nothing Then
                    Application.EnableEvents = False
                    targetCell.Offset(0, 2).Value = oCell.Offset(0, 8)
                    Application.EnableEvents = True
                End If
            Next
        End With
    End If
End Sub

Function GetWb(wbNameLike As String, ws As Worksheet) As Boolean
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.name Like "*" & wbNameLike & "*" Then '<-- check if workbook name contains "Depot Memo"
            Set ws = wb.Worksheets(1)
            Exit For
        End If
    Next
    GetWb = Not ws Is Nothing
End Function

如果值匹配，VBA会将值从一个工作簿复制到另一个工作簿？

2 个答案: