Question

我有两本工作簿。

练习册A

Item number     Item description     Supplier name        
1234            x                    c
123             y                    r
1111            b                    e

练习册B：

1234      
123
1111

当用户在工作簿B中输入或粘贴项目编号时，应从工作簿A中提取项目描述和供应商名称。

这很有效。但有时它有点气质。有时代码可以正常工作，但随后用户对工作簿进行更改时，就像他们删除工作簿B中的行一样，这将阻止代码在下次用户输入项目编号时执行。

这是我的代码：

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Message
On Error Resume Next

ActiveSheet.DisplayPageBreaks = False        

'Insert Depot Memo Data for user
 Dim oCell As Range, targetCell As Range
    Dim ws2 As Worksheet
    On Error GoTo Message
    If Not Intersect(Target, Range("B:B")) Is Nothing Then ' <-- run this code only if a value in column B 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                                                                        
                    'Set Format of cell
                    targetCell.ClearFormats
                    targetCell.Font.Name = "Arial"
                    targetCell.Font.Size = "10"
                    targetCell.Font.Color = RGB(128, 128, 128)
                    targetCell.HorizontalAlignment = xlCenter
                    targetCell.VerticalAlignment = xlCenter
                    targetCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
                    targetCell.Borders(xlEdgeTop).LineStyle = xlContinuous
                    targetCell.Borders.Color = RGB(166, 166, 166)
                    targetCell.Borders.Weight = xlThin                                                                        
                    targetCell.Offset(0, -1).Value = Now()
                    targetCell.Offset(0, 1).Value = oCell.Offset(0, 1)
                    targetCell.Offset(0, 2).Value = oCell.Offset(0, -2)
                    targetCell.Offset(0, 3).Value = oCell.Offset(0, -7)

                    Application.EnableEvents = True
                End If
            Next
        End With
    End If                       

Application.ScreenUpdating = True
Application.DisplayAlerts = True                                
Exit Sub        

Message:
Application.DisplayAlerts = False
Exit Sub

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从其他工作簿查找值并复制相应的值？

0 个答案: