[已解决]批量查找物料库位

dragon840919

之前dsmch老师写过一个，没太看懂代码的意思，现在数据源改了，烦劳哪位大师帮忙改一下代码，万分感谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2016-6-25 11:24

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Sheets("配料").Activate
   
4. With Sheet2
   
5.     For i = 2 To Range("a65536").End(xlUp).Row
   
6.         jm = Cells(i, 1): sl = Cells(i, 4): p = ""
   
7.         For j = 2 To .Range("a65536").End(xlUp).Row
   
8.             If .Cells(j, 4) = jm And .Cells(j, "m") > 0 Then
   
9.                 p = p & .Cells(j, 3) & "," & .Cells(j, "k")
   
10.                 If sl >= .Cells(j, "m") Then
    
11.                     p = p & "," & .Cells(j, "m") & Chr(10)
    
12.                     sl = sl - .Cells(j, "m")
    
13.                     .Cells(j, "m") = 0
    
14.                 Else
    
15.                     p = p & "," & sl & Chr(10)
    
16.                     .Cells(j, "m") = .Cells(j, "m") - sl
    
17.                     Exit For
    
18.                 End If
    
19.             End If
    
20.         Next
    
21.         Cells(i, 6) = p
    
22.     Next
    
23. End With
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Sheets("配料").Activate
   
4. With Sheet2
   
5.     For i = 2 To Range("a65536").End(xlUp).Row
   
6.         jm = Cells(i, 1): sl = Cells(i, 4): p = ""
   
7.         For j = 2 To .Range("a65536").End(xlUp).Row
   
8.             If .Cells(j, 4) = jm And .Cells(j, "m") > 0 Then
   
9.                 p = p & .Cells(j, 3) & "," & .Cells(j, "k")
   
10.                 If sl >= .Cells(j, "m") Then
    
11.                     p = p & "," & .Cells(j, "m") & Chr(10)
    
12.                     sl = sl - .Cells(j, "m")
    
13.                     .Cells(j, "m") = 0
    
14.                 Else
    
15.                     p = p & "," & sl & Chr(10)
    
16.                     .Cells(j, "m") = .Cells(j, "m") - sl
    
17.                     Exit For
    
18.                 End If
    
19.             End If
    
20.         Next
    
21.         Cells(i, 6) = p
    
22.     Next
    
23. End With
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码