请教：合并相同内容单元格

cjc209

ykcbf1100 发表于 2024-2-10 22:05
js不会，也不去学了。

js比vba简单多了  

ykcbf1100

cjc209 发表于 2024-2-10 22:06
js比vba简单多了

看上去代码量是少多了

cjc209

ykcbf1100 发表于 2024-2-10 22:05
js不会，也不去学了。

特别是在数组方面 灵活性比vba强100倍 一旦你接触他 你就会爱上他

cjc209

var arr=[...Sheets].flatMap(sht=>sht.Range("a1").CurrentRegion.Value2) 这就是一薄多表的原生代码合并数据  vba能这样简短的语句完成吗?办不到

cjc209

ykcbf1100 发表于 2024-2-10 22:08
看上去代码量是少多了

你那么聪明 包你一周就能学会

forestry1992

cjc209 发表于 2024-2-10 21:50
wps js宏代码

非常感谢您！
由于其他相关统计内容用vba写的，可否请老师改成vba，感谢！

cjc209

Sub MergeCells_相同单元格()
    Dim rng As Range
    Set rng = Sheets("Sheet2").Range("B4").CurrentRegion
   
    ' 合并行方向上的相同单元格
    For i = rng.Rows.Count - 1 To 1 Step -1
        For j = 1 To rng.Columns.Count
            If rng.Cells(i, j).Value2 = rng.Cells(i + 1, j).Value2 Then
                rng.Cells(i, j).Resize(2, 1).Merge
            End If
        Next j
    Next i
   
    ' 合并列方向上的相同单元格
    For j = rng.Columns.Count - 1 To 1 Step -1
        For i = rng.Rows.Count To 1 Step -1
            Dim tj As Boolean
            tj = (rng.Cells(i, j).MergeArea.Cells(1, 1).Value2 = rng.Cells(i, j + 1).MergeArea.Cells(1, 1).Value2)
            
            If tj Then
                Union(rng.Cells(i, j).MergeArea, rng.Cells(i, j + 1).MergeArea).Merge
            End If
        Next i
    Next j
End Sub

cjc209

合并相同单元格vba 自定义函数
Sub MergeCells_相同单元格(rng, Optional fx = "rc")
    Set rng = rng
    If fx = "rc" Then
        ' 合并行方向上的相同单元格
        For i = rng.Rows.Count - 1 To 1 Step -1
            For j = 1 To rng.Columns.Count
                If rng.Cells(i, j).Value2 = rng.Cells(i + 1, j).Value2 Then
                    rng.Cells(i, j).Resize(2, 1).Merge
                End If
            Next j
        Next i
        ' 合并列方向上的相同单元格
        For j = rng.Columns.Count - 1 To 1 Step -1
            For i = rng.Rows.Count To 1 Step -1
                tj = (rng.Cells(i, j).MergeArea.Cells(1, 1).Value2 = rng.Cells(i, j + 1).MergeArea.Cells(1, 1).Value2)
                If tj Then
                    Union(rng.Cells(i, j).MergeArea, rng.Cells(i, j + 1).MergeArea).Merge
                End If
            Next i
        Next j
    End If
    If fx = "r" Then
        For i = rng.Rows.Count - 1 To 1 Step -1
            For j = 1 To rng.Columns.Count
                If rng.Cells(i, j).Value2 = rng.Cells(i + 1, j).Value2 Then
                    rng.Cells(i, j).Resize(2, 1).Merge
                End If
            Next j
        Next i
    End If
    If fx = "c" Then
        For j = rng.Columns.Count - 1 To 1 Step -1
            For i = rng.Rows.Count To 1 Step -1
                tj = (rng.Cells(i, j).MergeArea.Cells(1, 1).Value2 = rng.Cells(i, j + 1).MergeArea.Cells(1, 1).Value2)
                If tj Then
                    Union(rng.Cells(i, j).MergeArea, rng.Cells(i, j + 1).MergeArea).Merge
                End If
            Next i
        Next j
    End If
End Sub

ykcbf1100

cjc209 发表于 2024-2-10 23:57
Sub MergeCells_相同单元格()
    Dim rng As Range
    Set rng = Sheets("Sheet2").Range("B4").Curren ...

你的代码思路挺好的，但细节上略有瑕疵，不能直接使用，因为附件中是没有Sheets2表的，另外呢，单元格每合并一次就会提示一下。现小改一下，便于直接使用了。

cjc209

ykcbf1100 发表于 2024-2-11 08:37
你的代码思路挺好的，但细节上略有瑕疵，不能直接使用，因为附件中是没有Sheets2表的，另外呢，单元格每 ...

没有必要拆消合并 因为你又没有填充值 没有价值 这一步