VBA触发代码范围设置问题

microyip

根据平时写码习惯写了段给你参考

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Set Target = Application.Intersect(Range("B10:B19"), Target)
   
3.     If Not Target Is Nothing Then 送检制单资料变动 Target
   
4. End Sub

复制代码

1. Private oDic As Object
   
2. 
   
3. Private Sub 物资资料初始化()
   
4.     Dim vData As Variant, nRow As Integer
   
5.     Dim sCode As String, sName As String, sPicCode As String
   
6.    
   
7.     If oDic Is Nothing Then
   
8.         Set oDic = CreateObject("Scripting.Dictionary")
   
9.     Else
   
10.         oDic.RemoveAll
    
11.     End If
    
12.     vData = Sheets("物资清单").UsedRange.Value
    
13.     For nRow = 2 To UBound(vData)
    
14.         sCode = Trim(vData(nRow, 1))
    
15.         sName = Trim(vData(nRow, 2))
    
16.         sPicCode = Trim(vData(nRow, 3))
    
17.         If sCode <> "" Then
    
18.             If Not oDic.Exists(sCode) Then Set oDic(sCode) = CreateObject("Scripting.Dictionary")
    
19.             oDic(sCode)("零件名称") = sName
    
20.             oDic(sCode)("图号") = sPicCode
    
21.         End If
    
22.     Next nRow
    
23. End Sub
    
24. 
    
25. Sub 送检制单资料变动(ByVal Target As Range)
    
26.     Dim vData As Variant, vFill As Variant, nRow As Integer, sCode As String
    
27.    
    
28.     Application.ScreenUpdating = False
    
29.     Application.Calculation = xlManual
    
30.     Application.EnableEvents = False
    
31.     If oDic Is Nothing Then 物资资料初始化
    
32.     If Target.Count > 1 Then
    
33.         vData = Target.Value
    
34.     Else
    
35.         ReDim vData(1 To 1, 1 To 1)
    
36.         vData(1, 1) = Target.Value
    
37.     End If
    
38.     ReDim vFill(1 To UBound(vData), 1 To 2)
    
39.     For nRow = 1 To UBound(vData)
    
40.         sCode = Trim(vData(nRow, 1))
    
41.         If sCode <> "" And oDic.Exists(sCode) Then
    
42.             vFill(nRow, 1) = oDic(sCode)("零件名称")
    
43.             vFill(nRow, 2) = oDic(sCode)("图号")
    
44.         End If
    
45.     Next nRow
    
46.     Target.Offset(, 1).Resize(, 2) = vFill
    
47.     Application.EnableEvents = True
    
48.     Application.ScreenUpdating = True
    
49.     Application.Calculation = xlAutomatic
    
50. End Sub

复制代码

microyip

附上附件以供参考

lsc900707

Amarry 发表于 2017-4-26 18:22
批量复制，然后批量匹配出结果，如果输入的条件不对想修改，支持批量删除，后面的信息也跟着删除掉，但是 ...

试试这样处理行不行：取消工作表事件，合并按钮

1. Sub 送检制单()
   
2.     Application.ScreenUpdating = False
   
3.     lsc
   
4.     Dim y As String, Dh As String, T As String, i
   
5.     y = "SJ" & Format(Now, "yyyymm")
   
6.     With Sheets("送检制单")
   
7.         .Range("G3") = y
   
8.         .Range("C7") = Format(Now, "yyyy/mm/dd hh:mm")
   
9.         T = Application.WorksheetFunction.Text(.Range("H3"), "000")
   
10.         Dh = .Range("G3") & T
    
11.             If .Range("C5") = "" Then
    
12.                 MsgBox "请选择送检人"
    
13.                 End
    
14.             End If
    
15.     End With
    
16.     If Sheets("送检制单").Range("B10").Value = "" Then
    
17.         MsgBox "请输入零件号"
    
18.         End
    
19.     End If
    
20.     If Sheets("送检制单").Range("E10").Value = "" Then
    
21.         MsgBox "请输入数量"
    
22.         End
    
23.         Else
    
24.     For i = 10 To 19
    
25.         If Cells(i, 2) <> "" Then
    
26.             With Sheets("送检记录")
    
27.                 r = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
    
28.                 .Cells(r, 1) = Range("C7")   '发货日期
    
29.                 .Cells(r, 2) = Cells(i, 2)   '零件简码
    
30.                 .Cells(r, 3) = Cells(i, 3)   '零件名称
    
31.                 .Cells(r, 4) = Cells(i, 4)   '图号
    
32.                 .Cells(r, 5) = Cells(i, 5)   '送检数量
    
33.                 .Cells(r, 6) = Cells(i, 6)   '炉号
    
34.                 .Cells(r, 7) = Cells(i, 7)   '批号
    
35.                 .Cells(r, 8) = Cells(i, 8)   '供应商
    
36.                 .Cells(r, 9) = Dh            '单号
    
37.                 .Cells(r, 10) = Range("C5")  '送检人
    
38.             End With
    
39.         End If
    
40.     Next
    
41.     End If
    
42.     With Sheets("送检制单")
    
43.         '.PrintOut Copies:=1
    
44.         .Range("H3") = T + 1
    
45.         .Range("C5") = ""
    
46.         .Range("B10:H19").ClearContents
    
47.     End With
    
48.     'ActiveWorkbook.Save
    
49.     Application.ScreenUpdating = True
    
50.     'ActiveWorkbook.Close savechanges:=ture
    
51. End Sub
    
52. Sub lsc()
    
53.     Set d = CreateObject("Scripting.Dictionary")
    
54.     arr = Sheet1.[a1].CurrentRegion
    
55.     For i = 2 To UBound(arr)
    
56.         d(arr(i, 1)) = arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4)
    
57.     Next
    
58.     brr = Range("a10:h" & Cells(Rows.Count, 1).End(3).Row)
    
59.     For i = 1 To UBound(brr)
    
60.        If d.exists(brr(i, 2)) Then
    
61.            s = Split(d(brr(i, 2)), "/")
    
62.            Cells(i + 9, 3) = s(0)
    
63.            Cells(i + 9, 4) = s(1)
    
64.            Cells(i + 9, 8) = s(2)
    
65.        End If
    
66.    Next
    
67.    Set d = Nothing
    
68. End Sub
    

复制代码

Amarry

microyip 发表于 2017-4-26 19:44
附上附件以供参考

感谢老师！这代码我慢慢消化下，不过“供应商”没有匹配出来，暂时还没摸清楚怎么改动。

Amarry

lsc900707 发表于 2017-4-26 20:10
试试这样处理行不行：取消工作表事件，合并按钮

这个也很好，一对三查找多列匹配，这两天正好在研究这个，收下了，嘻嘻！非常感谢老师！

Amarry

microyip 发表于 2017-4-26 19:43
根据平时写码习惯写了段给你参考

老师，我修改了下代码，可以匹配出供应商，但是怎么能把供应商分离出来放置在第6列的位置啊？到这我就不会改了，理解能力实在有限了0.0

1. Sub 送检制单资料变动(ByVal Target As Range)
   
2.     Dim vData As Variant, vFill As Variant, nRow As Integer, sCode As String
   
3.    
   
4.     Application.ScreenUpdating = False
   
5.     Application.Calculation = xlManual
   
6.     Application.EnableEvents = False
   
7.     If oDic Is Nothing Then 物资资料初始化
   
8.     If Target.Count > 1 Then
   
9.         vData = Target.Value
   
10.     Else
    
11.         ReDim vData(1 To 1, 1 To 1)
    
12.         vData(1, 1) = Target.Value
    
13.     End If
    
14.     ReDim vFill(1 To UBound(vData), 1 To 3)
    
15.     For nRow = 1 To UBound(vData)
    
16.         sCode = Trim(vData(nRow, 1))
    
17.         If sCode <> "" And oDic.Exists(sCode) Then
    
18.             vFill(nRow, 1) = oDic(sCode)("零件名称")
    
19.             vFill(nRow, 2) = oDic(sCode)("图号")
    
20.             vFill(nRow, 3) = oDic(sCode)("供应商")
    
21.         End If
    
22.     Next nRow
    
23.     Target.Offset(, 1).Resize(, 3) = vFill
    
24.     Application.EnableEvents = True
    
25.     Application.ScreenUpdating = True
    
26.     Application.Calculation = xlAutomatic
    
27. End Sub

复制代码

microyip

Amarry 发表于 2017-4-27 20:38
老师，我修改了下代码，可以匹配出供应商，但是怎么能把供应商分离出来放置在第6列的位置啊？到这我就不 ...

把vFill改成(……,1 To 6)

Amarry

microyip 发表于 2017-4-27 22:35
把vFill改成(……,1 To 6)

好的，谢谢老师！