- Sub test()
- Dim d, dic, arr, brr(), crr, drr(), err, i&, r&, m&, j%, n%, x%, y%, xy%, xy1%, xyy%, s1$, s2$, s3$
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- Set d2 = CreateObject("Scripting.Dictionary")
- Set dic = CreateObject("Scripting.Dictionary")
- Set dic1 = CreateObject("Scripting.Dictionary")
- With Sheet1
- r = .[A1].End(xlDown).Row
- .Range("K2:K" & r).ClearContents
- arr = .Range("A2:M" & r)
- ' Application.Wait (Now + TimeValue("0:00:03"))
- On Error Resume Next
- m = 0
- ReDim Preserve brr(m)
- brr(m) = 0
- For i = 1 To UBound(arr)
- If arr(i, 2) <> arr(i + 1, 2) Then
- m = m + 1
- ReDim Preserve brr(m)
- brr(m) = i
- End If
- Next
-
- ' d("@") = 0
- ' For i = 1 To UBound(arr)
- ' d(arr(i, 2)) = i
- ' Next
- ' brr = d.items
-
- For j = 0 To UBound(brr) - 1
- x = x + 1
- ReDim Preserve drr(1 To 2, 1 To x)
- drr(1, x) = brr(j) + 1
- drr(2, x) = brr(j + 1)
- Next
-
- For y = 1 To UBound(drr, 2)
- For xy = drr(1, y) To drr(2, y)
- For xy1 = drr(2, y) To drr(1, y) Step -1
- If InStr(arr(xy1, 10), "A8712") = 0 Then dic(arr(xy1, UBound(arr, 2))) = dic(arr(xy1, UBound(arr, 2))) & "," & arr(xy1, 9)
- dic1(arr(xy1, UBound(arr, 2))) = dic1(arr(xy1, UBound(arr, 2))) & "," & arr(xy1, 9)
- d2(arr(xy1, 9)) = ""
- Next
-
- If InStr(Join(d2.keys, ","), "E") Then
- For xyy = drr(1, y) To drr(2, y)
- err = Split(dic1(arr(xyy, UBound(arr, 2))), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- arr(xyy, 11) = Join(d1.keys, "+")
- Erase err: d1.RemoveAll
- Next
- End If
-
- If dic.Exists(53) And InStr(Join(d2.keys, ","), "E") = 0 Then
- If InStr(dic(53), "D1") Or InStr(dic(53), "D2") Then
- s1 = "": s2 = "": s3 = ""
- For f = 51 To 52
- err = Split(dic(f) & dic(f + 2) & dic(f + 4), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- Select Case f
- Case 51: s1 = Join(d1.keys, "+")
- Case 52: s2 = Join(d1.keys, "+")
- End Select
- Erase err: d1.RemoveAll
- Next
- For xyy = drr(1, y) To drr(2, y)
- If InStr(arr(xyy, 10), "A8712") = 0 Then
- If arr(xyy, UBound(arr, 2)) = 51 Or arr(xyy, UBound(arr, 2)) = 53 Or arr(xyy, UBound(arr, 2)) = 55 Then
- arr(xyy, 11) = s1
- ElseIf arr(xyy, UBound(arr, 2)) = 52 Or arr(xyy, UBound(arr, 2)) = 54 Or arr(xyy, UBound(arr, 2)) = 56 Then
- arr(xyy, 11) = s2
- Else
- err = Split(dic(arr(xyy, UBound(arr, 2))), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- arr(xyy, 11) = Join(d1.keys, "+")
- Erase err: d1.RemoveAll: d2.RemoveAll
- End If
- Else
- err = Split(dic1(arr(xyy, UBound(arr, 2))), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- arr(xyy, 11) = Join(d1.keys, "+")
- Erase err: d1.RemoveAll: d2.RemoveAll
- End If
- Next
- ElseIf InStr(dic(53), "F1") Or InStr(dic(53), "F2") Then
- s1 = "": s2 = "": s3 = ""
- For f = 51 To 53
- err = Split(dic(f) & dic(f + 3), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- Select Case f
- Case 51: s1 = Join(d1.keys, "+")
- Case 52: s2 = Join(d1.keys, "+")
- Case 53: s3 = Join(d1.keys, "+")
- End Select
- Erase err: d1.RemoveAll
- Next
- For xyy = drr(1, y) To drr(2, y)
- If InStr(arr(xyy, 10), "A8712") = 0 Then
- If arr(xyy, UBound(arr, 2)) = 51 Or arr(xyy, UBound(arr, 2)) = 54 Then
- arr(xyy, 11) = s1
- ElseIf arr(xyy, UBound(arr, 2)) = 52 Or arr(xyy, UBound(arr, 2)) = 55 Then
- arr(xyy, 11) = s2
- ElseIf arr(xyy, UBound(arr, 2)) = 53 Or arr(xyy, UBound(arr, 2)) = 56 Then
- arr(xyy, 11) = s3
- Else
- err = Split(dic(arr(xyy, UBound(arr, 2))), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- arr(xyy, 11) = Join(d1.keys, "+")
- Erase err: d1.RemoveAll: d2.RemoveAll
- End If
- Else
- err = Split(dic1(arr(xyy, UBound(arr, 2))), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- arr(xyy, 11) = Join(d1.keys, "+")
- Erase err: d1.RemoveAll: d2.RemoveAll
- End If
- Next
- End If
- Else
- For xyy = drr(1, y) To drr(2, y)
- err = Split(dic1(arr(xyy, UBound(arr, 2))), ",")
- For n = 1 To UBound(err)
- d1(err(n)) = ""
- Next
- arr(xyy, 11) = Join(d1.keys, "+")
- Erase err: d1.RemoveAll
- Next
- End If
- Next
- dic.RemoveAll: dic1.RemoveAll: d2.RemoveAll
- Next
- .[K2].Resize(UBound(arr), 1) = Application.WorksheetFunction.Index(arr, 0, 11)
- ' .[A2].Resize(UBound(arr), UBound(arr, 2)) = arr
- End With
- End Sub
复制代码
|