表格事件，动态配数据

yumz@123

大家好，做了一个表格事件的代码，经常出错，速度也慢，各位老师帮忙看看有什么问题？谢谢！


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, Jrng As Range, s As Range, r As Integer
On Error Resume Next
Application.EnableEvents = False

If Target.Row >= 3 Then
   r = Target.Row
   Range("a" & r, "s" & r).Borders.LineStyle = xlContinuous
Set rng = Sheet1.Range("c:c")

If Not Application.Intersect(Target, rng) Is Nothing Then '被改变单元格与a列存在交集
    '取出交集区域
    Set Jrng = Application.Intersect(Target, rng)
    For Each s In Jrng
          With Sheet3.Range("a1:a" & Sheet3.Range("a65536").End(xlUp).Row)
                            Set c = .Find(s.Value, LookIn:=xlValues)
        If s.Value <> "" Then
      
            s.Offset(0, -2) = Date
            s.Offset(0, 3) = c.Offset(0, 2).Value
            s.Offset(0, 5) = c.Offset(0, 3).Value
            s.Offset(0, 15) = c.Offset(0, 4).Value
             Else
            s.Offset(0, -2) = ""
            s.Offset(0, 3) = ""
            s.Offset(0, 5) = ""
            s.Offset(0, 15) = ""
        End If
    End With
   Next
End If
End If
Application.EnableEvents = True

Set rng = Sheet1.Range("e:e")
If Not Application.Intersect(Target, rng) Is Nothing Then '被改变单元格与a列存在交集
    '取出交集区域
    Set Jrng = Application.Intersect(Target, rng)
    For Each s In Jrng
    If s.Value <> "" Then
        s.Offset(0, 2) = s.Offset(0, 0) * s.Offset(0, 1)
        Else
        s.Offset(0, 2) = ""
        End If
    Next
End If

Set rng = Sheet1.Range("k:k")
If Not Application.Intersect(Target, rng) Is Nothing Then '被改变单元格与a列存在交集
    '取出交集区域
    Set Jrng = Application.Intersect(Target, rng)
    For Each s In Jrng
          With Sheet2.Range("a1:a" & Sheet2.Range("a65536").End(xlUp).Row)
                            Set c = .Find(s.Value, LookIn:=xlValues)
        If s.Value <> "" Then
            s.Offset(0, -1) = c.Offset(0, 11).Value
            s.Offset(0, 1) = c.Offset(0, 1).Value  '公司代码
            s.Offset(0, 2) = c.Offset(0, 4).Value   '目地库位
             If s.Offset(0, 7) = "乙类" Or s.Offset(0, 7) = "甲类" Then
                        s.Offset(0, 2) = c.Offset(0, 5).Value
                        s.Offset(0, 3) = c.Offset(0, 8).Value
                        s.Offset(0, 8) = c.Offset(0, 9).Value
                    Else
                        s.Offset(0, 2) = c.Offset(0, 4).Value
                        s.Offset(0, 3) = c.Offset(0, 7).Value
                        s.Offset(0, 8) = c.Offset(0, 10).Value
                    End If
            

            s.Offset(0, 5) = c.Offset(0, 3).Value    '时限
            s.Offset(0, 6) = Date + s.Offset(0, 5) '到货日期

            

          s.Offset(0, 8) = s.Offset(0, 1) & "-" & s.Offset(0, 2) & "-" & s.Offset(0, 3).Value

             Else
            
          s.Offset(0, -1) = ""
            s.Offset(0, 1) = ""
            s.Offset(0, 2) = ""
            s.Offset(0, 3) = ""
            s.Offset(0, 5) = ""
            s.Offset(0, 6) = ""
            s.Offset(0, 8) = ""

        End If
    End With
   Next


   
End If
Application.EnableEvents = True

End Sub

yumz@123

表格事件，各位老师帮忙看下，谢谢！！
说明：1，从测试数据复制数据“品名,料号,批次,数量”，F,H,J列对应的数据自动匹配数据（从物料Sheet中），并G列等于E列*F列。

蓝桥玄霜

工作表有保护密码？

selen

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim modifiedCell As Range
    Dim lookupData As Variant
    Dim lookupRange As Range
    Dim lookupResult As Range
   
    On Error Resume Next
    Application.EnableEvents = False

    ' 检查目标单元格是否位于当前工作表上
    If Target.Worksheet.Name <> Me.Name Then Exit Sub
   
    ' 将数据加载到数组中以提高性能
    lookupData = Sheet3.Range("A1:D" & Sheet3.Range("A65536").End(xlUp).Row).Value2
    Set lookupRange = Sheet3.Range("A1:A" & Sheet3.Range("A65536").End(xlUp).Row)

    For Each modifiedCell In Target.Cells
        If modifiedCell.Row >= 3 Then
            Select Case modifiedCell.Column
                Case Is = 3 ' 第3列被修改，更新相关单元格
                    If Not Intersect(modifiedCell, Range("C:C")) Is Nothing Then
                        ' 查找该值在Sheet3中的匹配项
                        Set lookupResult = lookupRange.Find(modifiedCell.Value, LookIn:=xlValues)
                        
                        If Not lookupResult Is Nothing Then
                            With modifiedCell
                                .Offset(0, -2) = Date
                                .Offset(0, 3) = lookupData(lookupResult.Row, 3)
                                .Offset(0, 5) = lookupData(lookupResult.Row, 4)
                                .Offset(0, 15) = lookupData(lookupResult.Row, 5)
                            End With
                        Else
                            With modifiedCell.Offset(0, -2)
                                .ClearContents
                                .Borders.LineStyle = xlNone
                            End With
                            With modifiedCell.Offset(0, 3)
                                .ClearContents
                                .Borders.LineStyle = xlNone
                            End With
                            With modifiedCell.Offset(0, 5)
                                .ClearContents
                                .Borders.LineStyle = xlNone
                            End With
                            With modifiedCell.Offset(0, 15)
                                .ClearContents
                                .Borders.LineStyle = xlNone
                            End With
                        End If
                    End If
               
                Case Is = 5 ' 第5列被修改，更新相关单元格
                    If Not Intersect(modifiedCell, Range("E:E")) Is Nothing Then
                        With modifiedCell
                            If .Value <> "" Then
                                .Offset(0, 2) = .Offset(0, 0) * .Offset(0, 1)
                            Else
                                .Offset(0, 2).ClearContents
                            End If
                        End With
                    End If
               
                Case Is = 11 ' 第11列被修改，更新相关单元格
                    If Not Intersect(modifiedCell, Range("K:K")) Is Nothing Then
                        ' 查找该值在Sheet2中的匹配项
                        Set lookupResult = Sheet2.Range("A:A").Find(modifiedCell.Value, LookIn:=xlValues)
                        
                        If Not lookupResult Is Nothing Then
                            With modifiedCell
                                .Offset(0, -1) = lookupResult.Offset(0, 11).Value
                                .Offset(0, 1) = lookupResult.Offset(0, 1).Value
                                
                                If .Offset(0, 7) = "乙类" Or .Offset(0, 7) = "甲类" Then
                                    .Offset(0, 2) = lookupResult.Offset(0, 5).Value
                                    .Offset(0, 3) = lookupResult.Offset(0, 8).Value
                                    .Offset(0, 8) = lookupResult.Offset(0, 9).Value
                                Else
                                    .Offset(0, 2) = lookupResult.Offset(0, 4).Value
                                    .Offset(0, 3) = lookupResult.Offset(0, 7).Value
                                    .Offset(0, 8) = lookupResult.Offset(0, 10).Value
                                End If
                                
                                .Offset(0, 5) = lookupResult.Offset(0, 3).Value
                                .Offset(0, 6) = Date + .Offset(0, 5)
                                .Offset(0, 8) = .Offset(0, 1) & "-" & .Offset(0, 2) & "-" & .Offset(0, 3).Value
                            End With
                        Else
                            With modifiedCell.Offset(0, -1)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                        With modifiedCell.Offset(0, 1)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                        With modifiedCell.Offset(0, 2)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                        With modifiedCell.Offset(0, 3)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                        With modifiedCell.Offset(0, 5)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                        With modifiedCell.Offset(0, 6)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                        With modifiedCell.Offset(0, 8)
                            .ClearContents
                            .Borders.LineStyle = xlNone
                        End With
                    End If
                End If
            
        End Select
    End If
Next modifiedCell

' 重新启用事件处理程序
Application.EnableEvents = True
End Sub

yumz@123

蓝桥玄霜 发表于 2023-4-9 10:24
工作表有保护密码？

老师好，没有密码

yumz@123

@selen，你好，我把代码放进去还是运行不了，有时间帮忙看下，谢谢！