再次做了修改,减化
- Sub test2()
- Dim arr, brr, crr, arr2, brr2, i&, j&, i2&, k, k2, s, s2, d As Object
- Set d = CreateObject("Scripting.Dictionary")
- arr = Sheets("用药收集表").Range("a2:e" & Cells(Rows.Count, 1).End(xlUp).Row)
- ReDim brr(1 To UBound(arr) / 3, 1 To 5)
- ReDim brr2(1 To UBound(arr) / 3, 1 To 8)
- For i = 1 To UBound(arr)
- s = arr(i, 1)
- If Not d.exists(s) Then
- k = k + 1
- d(s) = k
- brr(d(s), 1) = s
- brr(d(s), 2) = 1
- brr(d(s), 3) = i
- If brr2(d(s), 1) = Empty And brr2(d(s), 2) = Empty Then
- If s = arr(i + 1, 1) Then
- brr2(d(s), 1) = 1: brr2(d(s), 7) = False
- Else
- brr2(d(s), 1) = 0: brr2(d(s), 2) = 1: brr2(d(s), 8) = 0
- End If
- End If
- Else
- If brr(d(s), 2) + 2 = UBound(brr, 2) Then
- ReDim Preserve brr(1 To UBound(arr) / 3, 1 To brr(d(s), 2) + 3)
- End If
- brr(d(s), 2) = brr(d(s), 2) + 1
- brr(d(s), 4 + brr(d(s), 2) - 2) = i
- If brr2(d(s), 5) = Empty Then
- brr2(d(s), 5) = brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 3) - 1
- ElseIf brr2(d(s), 5) > 0 Then
- If (brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 4 + brr(d(s), 2) - 3) - 1) > brr2(d(s), 5) Then
- brr2(d(s), 5) = brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 4 + brr(d(s), 2) - 3) - 1
- End If
- End If
- If i < UBound(arr) Then
- If (s <> arr(i + 1, 1) And s = arr(i - 1, 1)) And brr2(d(s), 7) = False Then
- brr2(d(s), 1) = brr2(d(s), 1) + 1
- brr2(d(s), 7) = True
- ElseIf (s <> arr(i + 1, 1) And s = arr(i - 1, 1)) And brr2(d(s), 7) = True Then
- brr2(d(s), 3) = brr2(d(s), 3) + 1
- End If
- If s = arr(i + 1, 1) And brr2(d(s), 7) = False Then
- brr2(d(s), 1) = brr2(d(s), 1) + 1
- ElseIf s <> arr(i + 1, 1) And brr2(d(s), 7) = False Then
- brr2(d(s), 2) = brr2(d(s), 2) + 1
- ElseIf s = arr(i + 1, 1) And brr2(d(s), 7) = True Then
- brr2(d(s), 3) = brr2(d(s), 3) + 1
- ElseIf (s <> arr(i + 1, 1) And brr2(d(s), 7) = True) And s <> arr(i - 1, 1) Then
- brr2(d(s), 4) = brr2(d(s), 4) + 1: brr2(d(s), 8) = 0
- ElseIf (s <> arr(i - 1, 1) And brr2(d(s), 7) = True) And brr2(d(s), 3) > 0 Then
- brr2(d(s), 8) = brr2(d(s), 8) + 1
- End If
- Else
- s2 = brr(d(s), UBound(brr, 2) - 1) - brr(d(s), UBound(brr, 2) - 2)
- If s2 <= 1 And (s <> arr(i - 1, 1) And brr2(d(s), 7) = True) Then
- brr2(d(s), 8) = brr2(d(s), 8) + 1
- End If
- End If
- End If
- Next
- arr2 = Range("j2:j" & [j1].End(xlDown).Row).Value
- ReDim crr(1 To UBound(arr2), 1 To 6)
- For i = 1 To UBound(arr2)
- If d.exists(arr2(i, 1)) Then
- k2 = k2 + 1
- crr(k2, 1) = brr2(d(arr2(i, 1)), 5)
- crr(k2, 2) = brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 2) - brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 1) - 1
- crr(k2, 3) = UBound(arr) - brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 2)
- If brr2(d(arr2(i, 1)), 3) > 0 Then
- If brr2(d(arr2(i, 1)), 3) > brr2(d(arr2(i, 1)), 1) Then
- crr(k2, 4) = brr2(d(arr2(i, 1)), 3)
- Else
- crr(k2, 4) = brr2(d(arr2(i, 1)), 1)
- crr(k2, 5) = brr2(d(arr2(i, 1)), 4)
- End If
- Else
- crr(k2, 4) = brr2(d(arr2(i, 1)), 1)
- crr(k2, 5) = brr2(d(arr2(i, 1)), 2)
- End If
- crr(k2, 6) = brr2(d(arr2(i, 1)), 8)
- If crr(k2, 3) > crr(k2, 1) Then crr(k2, 1) = crr(k2, 3)
- End If
- Next
- Sheets("用药收集表").Range("k2").Resize(k2, 6) = crr
- End Sub
复制代码 |