有偿求助，删除符合条件的行

liren009

绝对会给钱，详细说明看我附件，接单联系1992928400


对于工作薄“做分表前的总表”，工作薄4，5，7，这个4个工作薄做处理。

对于D列，最后一个斜杠“/”后面，常见电镀或者喷漆颜色做处理。

常见颜色如下：

           韩国金
           韩国金+象牙白

           土豪金
           土豪金+酒红

           香槟金
           香槟金+象牙白

           
           美金
           美金+象牙白

           S金
           S金+象牙白

           拉丝铜本色
           拉丝铜本色+擦咖啡

现在要求，对于有+颜色的，把同单据日期，同型号的一行或者几行都删除掉。
即，首先查找D列最后一个斜杠后面，颜色有+的，对于上述带加号的颜色，
找到它，然后再去找与它A,B列都相同的行，这一行必然是没带加号的颜色，
一般都会找到，找不到就不做任何动作，找到了就把同A,B列值的，没带加号
颜色的行，一行或者几行，删除掉。

liren009

附件在此呢

一把小刀闯天下

'参与一下，怎么理解怎么写，数据量大按无序来写的，速度有点慢。

'供参考

Option Explicit

Sub test()
  Dim i, j, mark, t, tt, arr, sht
  mark = "做457"
  Application.ScreenUpdating = False
  For Each sht In Sheets
    If InStr(mark, Left(sht.Name, 1)) Then
      With Sheets(sht.Name)
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr, 1)
          If InStr(arr(i, 4), "/") Then
            t = Split(arr(i, 4), "/"): t = t(UBound(t))
            If InStr(t, "+") Then
              t = Split(t, "+")
              For j = 2 To UBound(arr, 1)
                If Len(arr(j, 1)) Then
                  If arr(i, 1) & arr(i, 2) = arr(j, 1) & arr(j, 2) Then
                    If InStr(arr(j, 4), "/") Then
                      tt = Split(arr(j, 4), "/")
                      If tt(UBound(tt)) = t(0) Or tt(UBound(tt)) = t(1) Then arr(j, 1) = vbNullString
                    End If
                  End If
                End If
              Next
            End If
          End If
        Next
        For i = UBound(arr, 1) To 2 Step -1
          If Len(arr(i, 1)) = 0 Then .Rows(i).Delete
        Next
      End With
    End If
  Next
  Application.ScreenUpdating = True
End Sub

liren009

用这个测试吧，上一个附件无效的

liren009

按照这个要求，去掉绿色的行，用代码，留下其他的别动

一把小刀闯天下

'不会这么简单吧，不匹配颜色？

'型号有2个，取得是第二列

Option Explicit

Sub test()
  Dim arr, dic, i, j, s, t, n
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 4), "/") Then
      t = Split(arr(i, 4), "/")
      If InStr(t(UBound(t)), "+") Then dic(arr(i, 1) & arr(i, 2)) = vbNullString
    End If
  Next
  n = 1
  For i = 2 To UBound(arr, 1)
    s = arr(i, 1) & arr(i, 2)
    If dic.exists(s) Then
      If InStr(arr(i, 4), "+") Then
        n = n + 1
        For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
      End If
    Else
      n = n + 1
      For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
    End If
  Next
  With [a1]
    .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    .Resize(n, UBound(arr, 2)) = arr
  End With
End Sub

一把小刀闯天下

'可能是这样？3楼的代码改写的，但颜色需要先定义好。觉得3楼的代码更靠谱些。

Option Explicit

Sub test()
  Dim arr, dic(1), i, j, s, t, n
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  t = Split("韩国金 象牙白 土豪金 酒红 香槟金 象牙白 美金 象牙白 S金 象牙白 拉丝铜本色")
  For i = 0 To UBound(t): dic(1)(t(i)) = vbNullString: Next
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 4), "/") Then
      t = Split(arr(i, 4), "/")
      If InStr(t(UBound(t)), "+") Then dic(0)(arr(i, 1) & arr(i, 2)) = vbNullString
    End If
  Next
  n = 1
  For i = 2 To UBound(arr, 1)
    s = arr(i, 1) & arr(i, 2)
    If dic(0).exists(s) Then
      If InStr(arr(i, 4), "/") Then
        t = Split(arr(i, 4), "/")
        If InStr(arr(i, 4), "+") Or Not dic(1).exists(t(UBound(t))) Then
          n = n + 1
          For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
        End If
      Else
        n = n + 1
        For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
      End If
    Else
      n = n + 1
      For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
    End If
  Next
  With [a1]
    .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    .Resize(n, UBound(arr, 2)) = arr
  End With
End Sub

一把小刀闯天下

3楼的代码修改了一下，觉得3楼的代码会更靠谱些
用这个测试去掉不带加号的物料.zip (15.1 KB, 下载次数: 1)

2018-6-23 09:32 上传

点击文件名下载附件

一把小刀闯天下

'再猜一个：

'纯看图写代码,按子件描述来瞎掰。觉得你这描述有问题，最终变成了一个文字题。

Option Explicit

Sub test()
  Dim arr, i, j, t, s, n, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 4), "/") Then
      t = Split(arr(i, 4), "/")
      If InStr(t(UBound(t)), "+") Then
        t = Replace(arr(i, 4), t(UBound(t)), vbNullString)
        dic(t) = vbNullString
      End If
    End If
  Next
  n = 1
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 4), "/") Then
      t = Split(arr(i, 4), "/"): s = t(UBound(t))
      t = Replace(arr(i, 4), s, vbNullString)
      If dic.exists(t) Then
        If InStr(s, "+") Then
          n = n + 1
          For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
        End If
      Else
        n = n + 1
        For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
      End If
    Else
      n = n + 1
      For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
    End If
  Next
  With [a1]
    .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    .Resize(n, UBound(arr, 2)) = arr
  End With
End Sub

liren009

此贴作废，看我新贴