大神帮忙看看，非常感谢！

感恩人

描述如图，运行如下代码时提示438错误，不知道怎么改了，大声帮帮我看下非常感谢。
代码如下：

Sub RemoveDuplicatesAndKeepMax()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim rng As Range
    Dim cell As Range
    Dim uniqueValues As New Collection
    Dim maxValueIndex As Long
    Dim maxValue As Variant
    Dim i As Long
    Dim keepValue As Variant
   
    ' 假设代码被添加到ThisWorkbook级别，并且应用于活动表
    Set ws = ThisWorkbook.ActiveSheet
   
    ' 找到数据最后使用的行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    ' 创建一个范围用于后续操作，这里假设A列是列索引1，B列是列索引2
    Set rng = ws.Range("A1:B" & lastRow)
   
    ' 遍历A列和B列，将不重复的值加入到集合uniqueValues中
    For Each cell In rng.Columns(1)
        If Not IsEmpty(cell) Then
            If Not uniqueValues.Exists(cell.Value) Then
                uniqueValues.Add cell.Value, cell.Offset(0, 1).Value
            Else
                ' 如果值已存在，则比较B列的值，并保留最大的那个
                maxValueIndex = 0
                maxValue = uniqueValues(cell.Value)
                keepValue = uniqueValues(cell.Value) ' 保留当前要比较的值
               
                ' 寻找当前值在集合中的位置
                For i = 1 To uniqueValues.Count
                    If uniqueValues.Item(i) = cell.Value Then
                        If cell.Offset(0, 1).Value > maxValue Then
                            maxValue = cell.Offset(0, 1).Value
                            maxValueIndex = i
                        End If
                        Exit For
                    End If
                Next i
               
                ' 如果当前值小于集合中的值，则替换掉最小的那个值
                If maxValueIndex > 0 Then
                    uniqueValues.Remove (maxValueIndex - 1)
                End If
                uniqueValues.Add keepValue, cell.Offset(0, 1).Value
            End If
        End If
    Next cell
   
    ' 清空原始数据范围并写入结果
    rng.ClearContents
    With rng.Offset(0, 0) ' 从原始数据的下一行开始写入结果
        For i = 1 To uniqueValues.Count
            .Cells(i) = uniqueValues.Item(i) ' 将值写入单元格中
        Next i
    End With
End Sub

ykcbf1100

还是新写一个吧。

ykcbf1100

排重、提取最高价

1. Sub ykcbf()   '//2024.7.12
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 2)
   
6.         ReDim brr(1 To UBound(arr), 1 To 2)
   
7.         For i = 2 To UBound(arr)
   
8.             s = arr(i, 1)
   
9.             If Not d.exists(s) Then
   
10.                 m = m + 1
    
11.                 d(s) = m
    
12.                 brr(m, 1) = s
    
13.                 brr(m, 2) = arr(i, 2)
    
14.             Else
    
15.                 r = d(s)
    
16.                 brr(r, 2) = IIf(brr(r, 2) < arr(i, 2), arr(i, 2), brr(r, 2))
    
17.             End If
    
18.         Next
    
19.         .[g2:h1000] = ""
    
20.         .[g2].Resize(m, 2) = brr
    
21.     End With
    
22.     Set d = Nothing
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

感恩人

ykcbf1100 发表于 2024-7-12 10:27
还是新写一个吧。

大声帮忙看看哪里的问题，我都魔怔了

ykcbf1100

感恩人 发表于 2024-7-12 10:30
大声帮忙看看哪里的问题，我都魔怔了

你那是AI写的代码，我看不懂。

感恩人

ykcbf1100 发表于 2024-7-12 10:27
还是新写一个吧。

您的这个代码，只能顺序保留，我想要保留重复里最高单价的

ykcbf1100

感恩人 发表于 2024-7-12 10:35
您的这个代码，只能顺序保留，我想要保留重复里最高单价的

是保留最高价啊，你打乱顺序也是这个结果

感恩人

感恩人 发表于 2024-7-12 10:35
您的这个代码，只能顺序保留，我想要保留重复里最高单价的

liulang0808

供参考

yang央

Dim uniqueValues As New Collection
collection 没有exists方法，那是dictionary才有exists