帮帮忙写VBA代码。谢谢！！

zw0713

麻烦老师写VBA代码。谢谢！！！！！

一条鱼ONE-FISH

只写了一个表格，其余的方法类似

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim i As Byte, j As Byte, Rng As Range, Sht As Worksheet
   
3. If Not Target.Address = "$C$8" Then Exit Sub
   
4. Set Sht = Worksheets("配套清单序时簿")
   
5. Set Rng = Sht.Range("B1:B" & Sht.Cells(Rows.Count, 2).End(xlUp).Row).Find(Target)
   
6. If Rng Is Nothing Then
   
7.     MsgBox "请检查产品编码是否正确"
   
8.     Exit Sub
   
9. Else
   
10.     Application.ScreenUpdating = False
    
11.     If Application.WorksheetFunction.CountA(Rng.Resize(100, 1)) >= 2 Then
    
12.         i = Rng.End(xlDown).Row - Rng.Row
    
13.     Else
    
14.         i = Rng.Offset(0, 10).End(xlDown).Row - Rng.Row + 1
    
15.     End If
    
16.    
    
17.     For j = 1 To i
    
18.         Rng.Offset(j - 1, 10).Copy
    
19.         Range("G" & 14 + j).Select
    
20.         ActiveSheet.Paste
    
21.         
    
22.         Rng.Offset(j - 1, 7).Copy
    
23.         Range("M" & 14 + j).Select
    
24.         ActiveSheet.Paste
    
25.     Next j
    
26.     Application.ScreenUpdating = True
    
27. End If
    
28. End Sub

复制代码

一条鱼ONE-FISH

新增了一行代码
更新时先删除原有内容

huangling888

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim i, j, k, m, arr
   
3. 'On Error Resume Next
   
4. arr = Sheet2.Range("a1:o65536")
   
5. m = 15
   
6. i = Application.Match(Range("c8"), Sheet2.Range("b1:b65536"), 0)
   
7. If Not IsError(i) Then
   
8. For j = i To 65536
   
9.    If arr(j + 1, 2) <> "" Then
   
10.    Exit For
    
11. End If
    
12. Next j
    
13. [g15:m38] = ""
    
14. For k = i To j
    
15.   Cells(m, 7) = arr(k, 12)
    
16.   Cells(m, 13) = arr(k, 9)
    
17.   m = m + 1
    
18. Next k
    
19. Else: MsgBox "没有这个产品，请输入正确的产品编码。"
    
20. End If
    
21. End Sub
    

复制代码

请参考