Sub 找出选定范围内不重复的值() On Error Resume Next Dim d As Object Set d = CreateObject("scripting.dictionary") For c_i = 1 To selection.Columns.Count For Each ce In selection.Columns(c_i).Cells 'd.Add ce.Value, 1 If ce <> "" Then 'D(ce.Value) = "" If d.Exists(ce.Value) Then d(ce.Value) = d(ce.Value) + 1 Else d(ce.Value) = 1 End If End If Next Next 'Debug.Print d.Count If MsgBox("是否在邻列显示出现次数?", vbYesNo, "统计次数") = vbYes Then 标记 = True End If e = InputBox("希望在那个单元格下生成结果:", "结果输出", Chr(97 + selection.Columns(1).Cells(1).Column + 2) & selection.Columns(1).Cells(1).row) m = Left(e, 1) jj = Mid(e, 2, 1) Range(m & jj) = "不重复值" If 标记 = True Then Range(Chr((Asc(m) + 1)) & jj) = "频率" '大于1的值 End If For Each Key In d.Keys Range(m & (jj + 1)) = Key If 标记 = True Then ' If d(Key) > 1 Then Range(Chr((Asc(m) + 1)) & (jj + 1)) = d(Key) Range(Chr((Asc(m) + 1)) & (jj + 1)) = d(Key) End If jj = jj + 1 Next Set d = Nothing '最后进行排序 ' Range(m & selection.Columns(1).Cells(1).row & ":" & Chr((Asc(m) + 1)) & (jj)).Select Range(e & ":" & Chr((Asc(m) + 1)) & (jj)).Sort Key1:=Range(m & Mid(e, 2, 1) + 1), Order1:=xlAscending, HEADER:=xlYes _ , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin, DataOption1:=xlSortNormal End Sub