请写个vba谢谢

0wchz

说明312在a列24在b列，单个出现的数值是314，在c列，出现两次的是2放d列

说明144在a列144在b列，出现两次的是1放d列，出现4次的是4放在f列

ab列值相加是5，6个数字，出现次数只有【单个出现，出现2次 或3次 或 4次，最多四次】，请贴出vba谢谢

0wchz

For j = 1 To Len(s) - 3
For j1 = j + 1 To Len(s) - 2
For j2 = j1 + 1 To Len(s) - 1
For j3 = j2 + 1 To Len(s)
If Mid(s, j, 1) = Mid(s, j1, 1) And Mid(s, j, 1) = Mid(s, j2, 1) And Mid(s, j, 1) = Mid(s, j3, 1) Then s4 = s4 & Mid(s, j, 1)
Next j3, j2, j1, j
For j = 1 To Len(s) - 2
For j1 = j + 1 To Len(s) - 1
For j2 = j1 + 1 To Len(s)
If Mid(s, j, 1) = Mid(s, j1, 1) And Mid(s, j, 1) = Mid(s, j2, 1) Then s3 = s3 & Mid(s, j, 1)
Next j2, j1, j
s3 = Replace(s3, s4, "")
For j = 1 To Len(s) - 1
For j1 = j + 1 To Len(s)
If Mid(s, j, 1) = Mid(s, j1, 1) Then s2 = s2 & Mid(s, j, 1)
Next j1, j
s2 = Replace(s2, s4, "")
For j = 1 To Len(s3)
s2 = Replace(s2, Mid(s3, j, 1), "")
Next j
.Cells(i, "c") = s1: .Cells(i, "d") = s2: .Cells(i, "e") = s3: .Cells(i, "f") = s4
Next i
这是出现234次的代码，但是出现一次的代码不会

0wchz

说明，s=.cells(i,"a")&.cells(i,"b")

gwjkkkkk

同时出现二次或三次怎么放？

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, k&, dic As Object, strKey$, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    r = Cells(Rows.Count, "A").End(xlUp).Row
    ar = Range("A1:D" & r).Value
    ReDim br(1 To UBound(ar), 2 To 4)
    For i = 1 To UBound(ar)
        dic.RemoveAll
        For j = 1 To UBound(ar)
            If Len(ar(i, j)) Then
                For k = 1 To Len(ar(i, j))
                    strKey = Mid(ar(i, j), k, 1)
                    dic(strKey) = dic(strKey) + 1
                Next k
            End If
        Next j
        For j = 2 To 4
            For Each vKey In dic.keys
                If dic(vKey) = j Then
                   If Len(br(i, j)) = 0 Then
                       br(i, j) = vKey
                   Else
                       br(i, j) = br(i, j) & "," & vKey
                   End If
                End If
            Next
        Next j
    Next i
   
    Columns("D:F").Clear
    [D1].Resize(UBound(br), 3) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

0wchz

a,b列是以知，求cdef列，c列放一次出现的，d列放2次出现的，e列放3次出现的,f列放4次出现的，请加入代码，主要求出现一次的，再写吧，你们代码看不懂

ykcbf1100

有可能同时有2个以上的数字出现重复情况。出题不太严谨。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2025.1.26
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     On Error Resume Next
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         Intersect(.UsedRange, .[c:f]) = Empty
   
7.         arr = .[a1].Resize(r, 6)
   
8.         For i = 1 To UBound(arr)
   
9.             d.RemoveAll
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 b = CStr(arr(i, j))
    
12.                 For x = 1 To Len(b)
    
13.                     s = Mid(b, x, 1)
    
14.                     d(s) = d(s) + 1
    
15.                 Next
    
16.             Next
    
17.             st = ""
    
18.             For Each k In d.keys
    
19.                 If d(k) = 1 Then
    
20.                     st = st & k
    
21.                 Else
    
22.                     arr(i, d(k) + 2) = k
    
23.                 End If
    
24.             Next
    
25.             arr(i, 3) = st
    
26.         Next
    
27.         .[a1].Resize(r, 6) = arr
    
28.     End With
    
29.     Set d = Nothing
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码