VBA文盲救助，请各位老师帮忙看看能否用VBA完成，目前我是用公式加辅助列完成的，谢谢

2728911088

请各位老师帮忙看看能否用VBA替代公式，多谢！！

Moneky

能，但别问怎么做。

2728911088

Moneky 发表于 2019-8-23 22:47
能，但别问怎么做。

打扰了，谢谢！！

yooha

测试
对比匹配.zip (34.09 KB, 下载次数: 5)

2019-8-24 10:23 上传

点击文件名下载附件

Sub test()
Dim sz1, sz2, aa1, aa2, aa3, bb1, cc1
Sheet1.Range(Sheet1.Cells(3, 9), Sheet1.Cells(Sheet1.Cells(Rows.Count, 3).End(3).Row, 52)).ClearContents
sz1 = Sheet1.Range(Sheet1.Cells(2, 3), Sheet1.Cells(Sheet1.Cells(Rows.Count, 3).End(3).Row, 52))
sz2 = Sheet2.Range(Sheet2.Cells(2, 3), Sheet2.Cells(Sheet2.Cells(Rows.Count, 3).End(3).Row, 8))
For aa1 = 2 To UBound(sz1)
For bb1 = 1 To UBound(sz2)
If sz1(aa1, 1) = sz2(bb1, 1) Then
For aa2 = 10 To 22
If sz1(1, aa2) = sz2(bb1, 4) Then
sz1(aa1, aa2) = sz1(aa1, aa2) + sz2(bb1, 6)
aa3 = aa3 + sz2(bb1, 6)
Exit For
End If
Next
End If
Next
cc1 = sz1(aa1, 6)
If aa3 >= cc1 Then
sz1(aa1, 37) = "调整满足"
For aa2 = 10 To 22
If sz1(aa1, aa2) - cc1 >= 0 Then
sz1(aa1, aa2 + 13) = cc1
sz1(aa1, aa2 + 28) = sz1(aa1, aa2) - cc1
sz1(aa1, 36) = sz1(aa1, 36) & sz1(1, aa2) & ":" & sz1(aa1, aa2 + 13) & ";"
cc1 = 0
Exit For
Else
sz1(aa1, aa2 + 13) = sz1(aa1, aa2)
If sz1(aa1, aa2 + 13) <> Empty Then sz1(aa1, aa2 + 28) = 0
If sz1(aa1, aa2 + 13) <> Empty Then sz1(aa1, 36) = sz1(aa1, 36) & sz1(1, aa2) & ":" & sz1(aa1, aa2 + 13) & ";"
cc1 = cc1 - sz1(aa1, aa2)
End If
Next
Else
sz1(aa1, 37) = "无法调整"
For aa2 = 10 To 22
If sz1(aa1, aa2) <> Empty Then sz1(aa1, 36) = sz1(aa1, 36) & sz1(1, aa2) & "余量:" & sz1(aa1, aa2) & ";"
Next
End If
aa3 = 0
Next

daihao3018

我也来试下  新手学习中  代码比较笨  勿笑

1. Sub test()
   
2.     Dim w1, w2 As Worksheet
   
3.     Dim arr, brr
   
4.     Dim str As String
   
5.     Set w1 = Worksheets("结果")
   
6.     Set w2 = Worksheets("库存")
   
7.     Application.ScreenUpdating = False
   
8.     i = w2.Range("c65535").End(3).Row
   
9.     arr = w2.Range("c2:h" & i)
   
10.     i = w1.Range("c65535").End(3).Row
    
11.     For x = 3 To i
    
12.         For y = 12 To 24
    
13.             For Z = 1 To UBound(arr)
    
14.                 If w1.Cells(x, 3) = arr(Z, 1) And w1.Cells(2, y) = arr(Z, 4) Then
    
15.                     w1.Cells(x, y) = arr(Z, 6)
    
16.                 End If
    
17.             Next
    
18.         Next
    
19.         If w1.Cells(x, 8) - Application.WorksheetFunction.Sum(w1.Cells(x, 12).Resize(1, 12)) > 0 Then
    
20.             w1.Cells(x, 39) = "无法调整"
    
21.         Else
    
22.             tmp = 0
    
23.             For y = 12 To 24
    
24.                 tmp = tmp + w1.Cells(x, y)
    
25.                 If w1.Cells(x, 8) - tmp >= 0 Then
    
26.                     w1.Cells(x, y + 13) = w1.Cells(x, y)
    
27.                 Else
    
28.                     If w1.Cells(x, 8) - tmp < 0 Then
    
29.                         w1.Cells(x, y + 13) = w1.Cells(x, y) - (tmp - w1.Cells(x, 8))
    
30.                         Exit For
    
31.                     End If
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next
    
36.     For x = 3 To i
    
37.         str = ""
    
38.         For y = 12 To 24
    
39.             If Cells(x, y) - Cells(x, y + 13) = 0 Then
    
40.                 Cells(x, y + 28) = ""
    
41.             Else
    
42.                 Cells(x, y + 28) = Cells(x, y) - Cells(x, y + 13)
    
43.             End If
    
44.             If Cells(x, y + 13) <> "" Then
    
45.                 str = str & " " & Cells(2, y + 13) & "调整：" & Cells(x, y + 13)
    
46.             End If
    
47.             Cells(x, 38) = str
    
48.         Next
    
49.     Next
    
50.     Application.ScreenUpdating = True
    
51. End Sub
    

复制代码

2728911088

yooha 发表于 2019-8-24 10:23
测试

Sub test()

多谢，因为加班刚回来，所以才回复，多谢。！！

2728911088

daihao3018 发表于 2019-8-24 10:34
我也来试下  新手学习中  代码比较笨  勿笑

多谢，因为加班刚回来，所以才回复，多谢。！！