Sub TEST()
Dim xArea As Range, Arr, Brr, N&, i&, TR, T, TT$, xClmn As Range, xR As Range
Application.ScreenUpdating = False
[D:D].Copy [G:G]
Set xArea = Range([G2], [G65536].End(xlUp))
Set xClmn = Range([材質!D2], [材質!D65536].End(xlUp))
For Each xR In xClmn
If xR <> "" Then xArea.Replace xR, "_||" & xR & "_", Lookat:=xlPart
Next
Arr = xArea.Value
ReDim Brr(1 To UBound(Arr), 1 To xClmn.Count)
For i = 1 To UBound(Arr)
TR = Split(Arr(i, 1), "_"): N = 0: TT = ""
For Each T In TR
If Left(T, 2) = "||" And InStr(TT, T) = 0 Then
TT = TT & T: N = N + 1: Brr(i, N) = Mid(T, 3)
End If
Next
Next i
With [G2].Resize(UBound(Arr), xClmn.Count)
.Value = Brr
.Columns.AutoFit
End With
Beep
End Sub