'玩的很嗨是吧。最后给你变通一下。
Option Explicit
Sub test()
Dim arr, i, j, k, m, n, t, dic, max
Set dic = CreateObject("scripting.dictionary")
arr = Sheets("数据").[a1].CurrentRegion
ReDim brr(1 To UBound(arr, 1) * 2, 1 To UBound(arr, 2) / 9 * 2)
For j = 1 To UBound(arr, 1) - 9 Step 9
m = m + 1: n = 0: dic.RemoveAll
For k = (j - 1) + 4 To (j - 1) + 7 Step 3
For i = 2 To UBound(arr, 1)
If Not dic.exists(arr(i, k)) Then
If InStr(arr(i, k), "XY") > 0 Or InStr(arr(i, k), "XW") > 0 _
Or InStr(arr(i, k), "XYB") > 0 Then
t = Right(arr(i, k), Len(arr(i, k)) - IIf(InStr(arr(i, k), "XYB"), 3, 2))
If IsNumeric(t) Then
n = n + 1
brr(n, (m - 1) * 2 + 1) = arr(i, k)
brr(n, (m - 1) * 2 + 2) = arr(i, k + 1) - arr(i, k + 2)
dic(arr(i, k)) = vbNullString
If max < n Then max = n
End If
End If
End If
Next i, k, j
ReDim arr(1 To max, 1 To 6): m = 0: n = 0
For i = 1 To max
If InStr(brr(i, 1), "XYB") = 0 Then
m = m + 1: arr(m, 1) = brr(i, 1): arr(m, 2) = brr(i, 2)
Else
n = n + 1: arr(n, 5) = brr(i, 1): arr(n, 6) = brr(i, 2)
End If
arr(i, 3) = brr(i, 3): arr(i, 4) = brr(i, 4)
Next
With Sheets("想实现的结果").[f5]
.Resize(Rows.Count - 4, UBound(arr, 2)).ClearContents
.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub |