按商品名称识别配件明细

aman1516 · 发表于 2017-6-14 19:40

同一配件，在不同商品中的用量不一样，但数据源全部做在一起了，想通过商品名称自动筛选出来。
但现时的代码跑出来的结果有的对，有的丢数据（是否判断条件不充分？）请老师帮忙看下错在哪里，或判断处理上有无好的方法。
详见附件：

按名称识别配件明细.rar (62.28 KB, 下载次数: 14) 谢谢！

aman1516 · 发表于 2017-6-18 19:54

自己琢磨了几天了，还是理不清，想改用字典一对多，也不行，还望老师帮忙

laoau128 · 发表于 2017-6-18 19:59

aman1516 发表于 2017-6-18 19:54
自己琢磨了几天了，还是理不清，想改用字典一对多，也不行，还望老师帮忙

你也高手了

aman1516 · 发表于 2017-6-18 20:40

本帖最后由 aman1516 于 2017-6-18 21:13 编辑

勉强拼凑出来的：

Sub p()
Dim arr, brr, crr, i, j, k, m, n, r, c, p, sr, s, a
On Error Resume Next
r = Range("A65536").End(xlUp).Row
arr = Range("A3:N" & r)
sr = Array("二扇", "三扇", "2+1扇", "四扇", "4+2扇", "六扇")
p = Range("E2").Value
c = 0: k = 0
For s = 0 To UBound(sr)
If InStr(p, sr(s)) Then
c = s + 9
Exit For
End If
Next
ReDim brr(1 To UBound(arr), 1 To 7)
For i = 2 To UBound(arr)
If arr(i, 2) = "" Then
k = k + 1
If arr(i, 3) <> "" Then
If InStr(p, arr(i, 3)) > 0 and arr(i, 3) = "窗" And arr(i, 5) = arr(i - 1, 5) Then
k = k - 1
Else
If InStr(p, arr(i, 3)) = 0 Then
k = k - 1
GoTo 100
End If
End If
End If
brr(k, 1) = arr(i, 1)
For j = 4 To 8
brr(k, j - 2) = arr(i, j)
Next
brr(k, 7) = arr(i, c)
Else
If InStr(p, arr(i, 2)) > 0 Then
k = k + 1
If arr(i, 3) = "窗" And arr(i, 5) = arr(i - 1, 5) Then
k = k - 1
End If
brr(k, 1) = arr(i, 1)
For j = 4 To 8
brr(k, j - 2) = arr(i, j)
Next
brr(k, 7) = arr(i, c)
End If
End If
100:
Next
Range("C31:I50").ClearContents
Range("C31").Resize(k, 7) = brr
End Sub

复制代码

只是觉得方法很笨，所以求优化

aman1516 · 发表于 2017-6-18 22:21

结果如附件，在大批量数据验证中：

按名称识别配件明细.rar (25.75 KB, 下载次数: 20)

		自动登录	找回密码
密码			免费注册

[求助] 按商品名称识别配件明细