samwang

¦^´_ 1# Andy2483

±z¼g±o«Ü¦n¤F¡A°Ñ¦Ò±zªº­×§ï¤@¤U¡AÁÂÁÂ

Sub test()
Dim Arr, Brr, Crr, xD, xR, i&, j&, S&, N&, M&, R&, C&, D As Date
Set xD = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
    .Replace What:=" ", Replacement:="", LookAt:=xlPart
    .Sort Key1:=.Item(1), Order1:=1, Header:=1
    Arr = .Value
    Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
    .Clear
End With
ReDim Crr(1 To UBound(Arr), 1 To 2)
For Each xR In Brr
    If InStr(xR, "±è") Then
        S = InStr(xR, "±è") + 1
        N = InStr(xR, "(")
        D = Mid(xR, S, N - S)
        If Not xD.Exists(D) Then
            i = i + 1: xD(D) = i
            Crr(i, 1) = D: Crr(i, 2) = Trim(xR)
        End If
    End If
Next
With Sheets("Sheet3").[a1].Resize(i, 2)
        .Value = Crr
        .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
        Brr = .Value
        .Clear
End With
xD.RemoveAll
ReDim Crr(1 To UBound(Arr), 1 To i)
For i = 1 To UBound(Brr)
   M = M + 1: xD(Brr(i, 2)) = M
   Crr(1, M) = Brr(i, 2)
Next
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
        If Not xD.Exists(Arr(i, j) & "|" & Arr(i, 1)) Then
            R = xD(Arr(i, j) & "|R")
            If R = 0 Then R = R + 2 Else R = R + 1
            C = xD(Arr(i, j) & "")
            Crr(R, C) = Arr(i, 1)
            xD(Arr(i, j) & "|R") = R
            xD(Arr(i, j) & "|" & Arr(i, 1)) = ""
         End If
      End If
   Next j
Next i
[Sheet3!A1].Resize(UBound(Crr), M) = Crr
Application.Goto [Sheet3!A1]
End Sub