查找符合条件的值

jiangyuqin1025

查找符合条件的值

kankan1030

1. Sub tt()
   
2. arr = Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
   
3. brr = Range("g1:g" & Cells(Rows.Count, 7).End(xlUp).Row)
   
4. For i = 1 To UBound(arr)
   
5.     For j = 1 To UBound(brr)
   
6.         If arr(i, 1) = brr(j, 1) And arr(i, 2) <> "油面" Then
   
7.         n = n + 1
   
8.         Cells(n, "k").Resize(1, 4) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4))
   
9.         End If
   
10.     Next
    
11. Next
    
12. End Sub

复制代码

jiangyuqin1025

kankan1030 发表于 2018-8-24 11:38

还差一步，符合条件的提取完成后，剩下的数据也提取出来，放在P列

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, brr, crr, i, j, k, m, n
  arr = [a1].CurrentRegion: brr = [g1].CurrentRegion
  crr = arr
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(brr, 1)
      If arr(i, 1) = brr(j, 1) And arr(i, 2) <> "油面" Then Exit For
    Next
    If j = UBound(brr, 1) + 1 Then
      n = n + 1
      For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
    Else
      m = m + 1
      For j = 1 To UBound(arr, 2): crr(m, j) = arr(i, j): Next
    End If
  Next
  With [p1]
    .Resize(Rows.Count, UBound(arr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(arr, 2)) = arr
  End With
  With [k1]
    .CurrentRegion.ClearContents
    If m > 0 Then .Resize(m, UBound(crr, 2)) = crr
  End With
End Sub