Vba小司机遇到的难题

通过单元格与单元格比对，遍历整列单元格，把包含有单元格数字，但排序不一样的单元格合并（如第一个单元格的4332,假如其他单元格有2334和2343，2433，2433等都归为相等，并统计出现次数，其他单元格亦如此）

代码如下,如有帮助给个采纳谢谢

Sub MergeSameNumbers()
    Dim lastRow As Long
    Dim i, j, k, m As Integer
    Dim arr(), temp As Variant
    Dim range1, range2 As Range
    
    lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row ' 获取最后一行的行号
    
    ReDim arr(1 To lastRow, 1 To 3)
    
    ' 遍历整个区域，将单元格的值、索引、出现次数存入数组
    For i = 1 To lastRow
        arr(i, 1) = Cells(i, 1).Value
        arr(i, 2) = i
        arr(i, 3) = 1
        For j = i + 1 To lastRow
            If StrComp(CStr(arr(j, 1)), CStr(arr(i, 1)), vbTextCompare) = 0 Then
                arr(i, 3) = arr(i, 3) + 1 ' 出现次数加1
                Cells(j, 1).Value = "" ' 清空此单元格
            End If
        Next j
    Next i
    
    ' 对数组进行排序
    For i = 1 To lastRow - 1
        For j = i + 1 To lastRow
            If arr(i, 1) > arr(j, 1) Then
                For k = 1 To 3
                    temp = arr(i, k)
                    arr(i, k) = arr(j, k)
                    arr(j, k) = temp
                Next k
            End If
        Next j
    Next i
    
    ' 遍历数组，将出现次数大于1的单元格合并
    For i = 1 To lastRow - 1
        If arr(i, 3) > 1 Then
            Set range1 = Range(Cells(arr(i, 2), 1), Cells(arr(i, 2) + arr(i, 3) - 1, 1))
            For j = i + 1 To lastRow
                If arr(j, 3) > 1 And StrComp(CStr(arr(j, 1)), CStr(arr(i, 1)), vbTextCompare) = 0 Then
                    Set range2 = Range(Cells(arr(j, 2), 1), Cells(arr(j, 2) + arr(j, 3) - 1, 1))
                    Set range1 = Union(range1, range2)
                End If
            Next j
            range1.Merge ' 合并单元格
            m = m + 1 ' 计算合并单元格的数量
        End If
    Next i
    
    ' 输出结果
    MsgBox "成功合并了 " & m & " 个单元格。"
    
End Sub

Sub MergeCells()
    Dim countDict As Object
    Set countDict = CreateObject("Scripting.Dictionary")
    ' 创建一个字典，用于统计每个数字出现的次数

    Dim cell As Range, col As Range
    Dim strCell As String, sortedCell As String
    Dim num As Variant, count As Variant

    For Each col In Range("A1:C5").Columns
        ' 遍历每一列
        For Each cell In col.Cells
            ' 遍历每个单元格
            If IsNumeric(cell.Value) Then
                ' 如果单元格中包含数字
                strCell = CStr(cell.Value)
                ' 将数字转为字符串
                sortedCell = SortString(strCell)
                ' 对数字进行排序
                If countDict.Exists(sortedCell) Then
                    ' 如果排序后的数字已经存在于字典中，将出现次数加一
                    countDict(sortedCell) = countDict(sortedCell) + 1
                Else
                    ' 如果排序后的数字不存在于字典中，将其添加进字典，并将出现次数初始化为一
                    countDict.Add sortedCell, 1
                End If
            End If
        Next cell
    Next col

    For Each num In countDict.Keys
        ' 输出每个数字出现的次数
        count = countDict(num)
        Debug.Print num & "出现了" & CStr(count)
    Next num
End Sub

Function SortString(str As String) As String
    Dim arr() As String
    Dim i As Long, j As Long
    ReDim arr(1 To Len(str))
    For i = 1 To Len(str)
        arr(i) = Mid(str, i, 1)
    Next i
    For i = 1 To UBound(arr)
        For j = i + 1 To UBound(arr)
            If arr(j) < arr(i) Then
                Swap arr(i), arr(j)
            End If
        Next j
    Next i
    SortString = Join(arr, "")
End Function

Sub Swap(ByRef a As Variant, ByRef b As Variant)
    Dim tmp As Variant
    tmp = a
    a = b
    b = tmp
End Sub

这段代码假定您的数据范围为A1:C5，您可以根据您自己的数据范围进行更改

在Excel VBA中，可以编写以下代码来进行单元格值比较和合并操作：

vb

Sub mergeCells()
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long
    Dim count As Long
    Dim arr() As Variant
    Dim cell1 As Range, cell2 As Range
    
    lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' 获取列的最后一行
    
    ' 初始化数组，用于存储每个单元格的数据和出现次数
    ReDim arr(lastRow - 1, 2)
    For i = 0 To lastRow - 1
        arr(i, 0) = Cells(i + 1, 1).Value
        arr(i, 1) = 0
    Next i
    
    ' 遍历每个单元格，并与数组中的其他单元格比较
    For i = 0 To lastRow - 1
        If arr(i, 1) = 0 Then ' 如果该单元格还没有被合并
            Set cell1 = Cells(i + 1, 1)
            count = 1
            For j = i + 1 To lastRow - 1
                If arr(j, 1) = arr(i, 0) And arr(j, 1) <> "" Then ' 如果两个单元格的值相等且还没有被合并过
                    Set cell2 = Cells(j + 1, 1)
                    If (joinNums(cell1.Value) = joinNums(cell2.Value)) Then ' 如果两个单元格拆分后的数字排序一样
                        count = count + 1 ' 计算出现次数
                        arr(j, 1) = 1 ' 设为已合并
                        cell1.Value = cell1.Value & " / " & cell2.Value ' 合并单元格
                    End If
                End If
            Next j
            ' 更新出现次数
            arr(i, 1) = count
        End If
    Next i
    
    ' 将数组中被合并的单元格值设为空值
    For k = lastRow To 1 Step -1
        If arr(k - 1, 1) > 1 Then
            Range("A" & k).Value = ""
        End If
    Next k
End Sub

' 拆分单元格内的数字，并以升序重新连接
Function joinNums(nums As String) As String
    Dim arr() As String
    Dim i As Long
    
    arr = Split(nums, ",") ' 将逗号分隔的数字转换为数组
    For i = 0 To UBound(arr)
        arr(i) = Right("0000" & arr(i), 4) ' 补零使所有数字都有四位
    Next i
    joinNums = Join(SortByLength(arr), ",") ' 按数字位数排序并连接
End Function

' 根据数字位数排序数组
Function SortByLength(arr() As String) As Variant
    Dim i As Long, j As Long
    Dim temp As String
    
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Len(arr(i)) > Len(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    
    SortByLength = arr
End Function

上述代码通过使用数组存储每个单元格的数值和出现次数，并遍历每个单元格，将与之相等但还没有被合并的单元格合并。具体而言，程序会对每个单元格的数字进行拆分，并以数字升序重新连接。然后，程序会在数组中查找相等但还未被合并的单元格，如果两个单元格的数字排序一样，则合并这两个单元格，并更新出现次数。最后，程序将被合并的单元格值设为空值。

请在运行程序前，将需要操作的列设置为选中状态。另外，需要注意的是，本程序在比较时不考虑空单元格，因此您需要在Excel表格中手动删除空的单元格。如果您的数据包含多个列，可以将此程序放入循环中，以处理每个列。