符合多个条件的数据提取

andfor828

各位老师好！
参考这个附件，我想在不良明细这个表中查找符合条件的值，按行提取出来；
不知道这个可以实现吗？
在这个论坛里面找了很久也没有这样的例子。谢谢！

ericniming

这个用VBA不难实现，可以做的。

wodewan

高级筛选应该可以的，不过你的条件格式要稍微变下≥变成>=,还有LIne列的值变成 =LA1这样（精确匹配）

一把小刀闯天下

'结果对不上啊，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, p, dic, s
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("条件").[a1].CurrentRegion.Offset(1).Resize(, 4)
  For i = 1 To UBound(arr, 1) - 1
    arr(i, 4) = (Replace(arr(i, 3), "≥", vbNullString))
  Next
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, 4, 1)
  For i = 1 To UBound(arr, 1) - 1
    If arr(i, 1) <> arr(i + 1, 1) Then
      dic(arr(i, 1)) = Array(p + 1, i - p)
      Call bsort(arr, p + 1, i, 1, 4, 4)
      p = i
    End If
  Next
  With Sheets("不良明细")
    brr = .Range("d2:q" & .[d2].End(xlDown).Row)
    For i = 1 To UBound(brr, 1)
      If dic.exists(brr(i, 1)) Then
        s = vbNullString
        For j = dic(brr(i, 1))(0) To dic(brr(i, 1))(0) + dic(brr(i, 1))(1) - 1
          If brr(i, 12) >= Val(arr(j, 4)) Then
            s = s & "," & arr(j, 2)
          End If
        Next
        If Len(s) Then brr(i, 1) = Mid(s, 2) Else brr(i, 1) = vbNullString
      Else
        brr(i, 1) = vbNullString
      End If
    Next
    .[t2].Resize(UBound(brr, 1)) = brr
  End With
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) > arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

ericniming

用excel的公式筛选也可以的。我用字典简单做了下。我发现有些不良在条件里没有，vba执行时是默认>=0的时候就符合要求了。也可以修改。
Private Sub CommandButton1_Click()
  Set dic = CreateObject("scripting.dictionary")
  If Sheet2.Cells(2, 1) <> "" Then Sheet2.Range("A2:S" & Sheet2.Cells(Rows.Count, "S").End(xlUp).Row).Clear
  For i = 2 To 100
   dic(Sheet1.Cells(i, 1) & Sheet1.Cells(i, 2)) = Right(Sheet1.Cells(i, 3), 1) * 1
  Next i
  j = 2
  k = Sheet7.Cells(Rows.Count, "S").End(xlUp).Row
   For l = 2 To k
   If Sheet7.Cells(l, "O") >= dic(Sheet7.Cells(l, "D") & Sheet7.Cells(l, "S")) Then
    Sheet7.Cells(l, "O").EntireRow.Copy Sheet2.Cells(j, 1)
    j = j + 1
   End If
  Next l
End Sub

Jason_WangSS

试了一下，真搞不定

wodewan

补个图和结果你检查下，用高级筛选，字段名必须完全相同，你Defect_QTY在条件区域里是Defect QTY，少了个下划线_：如果能用PQ，好像PQ更简单，纯操作就可以得到结果，和高级筛选的结果一样，附件供参考。

andfor828

ericniming 发表于 2019-11-4 16:45
用excel的公式筛选也可以的。我用字典简单做了下。我发现有些不良在条件里没有，vba执行时是默认>=0的时候 ...

不良在条件内没有的是现在暂时不需要，数据源和条件后续都会更新呢！
所以可否在帮忙更新下代码。感谢！

andfor828

wodewan 发表于 2019-11-4 17:27
补个图和结果你检查下，用高级筛选，字段名必须完全相同，你Defect_QTY在条件区域里是Defect QTY，少了个下 ...

高级筛选的方法很有效，感谢！
PQ具体是怎样写的？麻烦告知。谢谢！

andfor828

一把小刀闯天下 发表于 2019-11-4 16:34
'结果对不上啊，，，

Option Explicit

我就是复杂的数组这块整不明白，有什么办法吗？老师。