请问如何去重复

529905149

请问用代码实现去重复,问题在附件中

一把小刀闯天下

'应该差不多

Option Explicit

Sub test()
  Dim arr, i, j, m, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  For i = 1 To UBound(arr, 1) - 1
    If InStr(arr(i, 1), "、") Then
      If IsNumeric(Split(arr(i, 1), "、")(0)) Then dic(arr(i, 1)) = 1
    End If
  Next
  For i = 1 To UBound(arr, 1) - 1
    If InStr(arr(i, 1), "、") Then
      If IsNumeric(Split(arr(i, 1), "、")(0)) And dic(arr(i, 1)) = 1 Then
        For j = i To UBound(arr, 1) - 1
          m = m + 1: arr(m, 1) = arr(j, 1)
          If Len(arr(j + 1, 1)) = 0 Then Exit For
          If InStr(arr(j + 1, 1), "、") Then
            If IsNumeric(Split(arr(j + 1, 1), "、")(0)) Then Exit For
          End If
        Next
        dic(arr(i, 1)) = 0: i = j
      End If
    End If
  Next
  With [b:b] ' 输出位置自己修改'
    .ClearContents
    If m > 0 Then .Resize(m) = arr
  End With
End Sub

529905149

一把小刀闯天下 发表于 2018-9-3 12:46
'应该差不多

Option Explicit

不好意思，我没有表达清楚问题，重新上传了附件，麻烦您看下，谢谢。

一把小刀闯天下

529905149 发表于 2018-9-3 14:25
不好意思，我没有表达清楚问题，重新上传了附件，麻烦您看下，谢谢。

'不就是相同的题目留第一个出现的吗？那你的去重是什么意思

'你这附件中也没有想要的结果数据或图示，你叫我找规则再写代码？

Option Explicit

Sub test()
  Dim arr, i, j, m, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  For i = 1 To UBound(arr, 1) - 1
    If Left(arr(i, 1), 1) = "（" Then dic(arr(i, 1)) = 1
  Next
  For i = 1 To UBound(arr, 1) - 1
    If Left(arr(i, 1), 1) = "（" And dic(arr(i, 1)) = 1 Then
      For j = i To UBound(arr, 1) - 1
        m = m + 1: arr(m, 1) = arr(j, 1)
        If Left(arr(j + 1, 1), 1) = "（" Then Exit For
      Next
      dic(arr(i, 1)) = 0: i = j
    End If
  Next
  With [b:b]
    .ClearContents
    If m > 0 Then .Resize(m) = arr
  End With
End Sub