根据四位数有无重复数字，进行调整，如何去做啊。

桑榆非晚

各位大神，如图所示，根据两种不同情况需要转换成对应数据，如何操作，谢谢各位大神，祝愿各位好心人全家幸福吉祥，好人到处是好运！！！


（我的数据库只有这两种情况：有两个重复数字，或没有重复数字。）

3190496160

Sub 调整()
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
r = Cells(Rows.Count, 1).End(xlUp).Row
ar = Range("a1:a" & r)
ReDim br(1 To UBound(ar), 1 To 1)
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        If Not d.exists(ar(i, 1)) Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
        d(ar(i, 1))(i) = ""
    End If
Next i
For Each k In d.keys
    m = 0
    For Each kk In d(k).keys
        n = n + 1
        br(n, 1) = ar(kk, 1) + m
        m = m + 1
    Next kk
Next k
For i = 1 To n
    For s = i + 1 To n
        If br(i, 1) > br(s, 1) Then
            tp = br(i, 1)
            br(i, 1) = br(s, 1)
            br(s, 1) = tp
        End If
    Next s
Next i
Columns(3) = Empty
[c2].Resize(n, 1) = br
MsgBox "ok!"
End Sub

3190496160

参考
根据四位数有无重复数字，进行调整，如何去做啊。.rar (14.44 KB, 下载次数: 6)

2024-8-13 10:55 上传

点击文件名下载附件

ykcbf1100

字典+ArrayList

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.13
   
2.     Application.ScreenUpdating = False
   
3.     Set List = CreateObject("System.Collections.ArrayList")
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     arr = [a1:c14]
   
6.     Columns(3).NumberFormatLocal = "@"
   
7.     For i = 2 To UBound(arr)
   
8.         List.Clear
   
9.         st = CStr(arr(i, 1))
   
10.         d.RemoveAll
    
11.         For x = 1 To Len(st)
    
12.             s = Mid(st, x, 1)
    
13.             d(s) = d(s) + 1
    
14.             t = d(s)
    
15.             If t = 1 Then
    
16.                 List.Add s
    
17.             Else
    
18.                 s = s + 5
    
19.                 List.Add Right(CStr(s), 1)
    
20.             End If
    
21.         Next
    
22.         List.Sort
    
23.         tt = ""
    
24.         For Each k In List
    
25.             tt = tt & k
    
26.         Next
    
27.         Cells(i, 3) = CStr(tt)
    
28.     Next
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

ynzsvt

参见D列的自定义公式结果

songshihai

如果加5了又有重复的了怎么办???????????????

kyxfyzg

字典、数组+排序

sdytsxd991122

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A2:A14].Value
    For i = 1 To UBound(ar)
        dic.RemoveAll
        For j = 1 To Len(ar(i, 1))
            dic(Mid(ar(i, 1), j, 1)) = dic(Mid(ar(i, 1), j, 1)) + 1
        Next j
        br = dic.keys
        For Each vKey In dic.keys
            If dic(vKey) > 1 Then
                ReDim Preserve br(UBound(br) + 1)
                br(UBound(br)) = Right(vKey + 5, 1)
                Exit For
            End If
        Next
        bSort1 br, 0, UBound(br)
        ar(i, 1) = Join(br, "")
    Next i
   
    With [n2].Resize(UBound(ar))
        .NumberFormatLocal = "@"
        .Value = ar
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

Function bSort1(ByRef ar, ByVal iFirst&, ByVal iLast&, _
    Optional ByVal isOrder As Boolean = True)
    Dim i&, j&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j) <> ar(j + 1) Then
                If ar(j) < ar(j + 1) Xor isOrder Then
                    vTemp = ar(j)
                    ar(j) = ar(j + 1)
                    ar(j + 1) = vTemp
                End If
            End If
        Next j
    Next i
End Function