首页 » 生活印记 » 正文

excel 实现合并单元格的代码

应业务需要进行了合并并计算亏耗数据

代码如下:

Sub 港口组_合并前三列()
Dim en&, i&, n&, y&, num&
num = 3
en = [A1048576].End(3).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While y < num
    y = y + 1
    i = 0
    Do While i <= en
        i = i + 1
        For n = i + 1 To en
            If Cells(i, y) <> Cells(n, y) Or n = en Then
                n = IIf(n = en, en, n - 1)
                Range(Cells(i, y), Cells(n, y)).Merge
                i = n
                Exit For
            End If
        Next
    Loop
    Columns(y).VerticalAlignment = xlCenter
Loop
End Sub


Sub 通用_处理当前列()
Dim en&, i&, n&, x&, y&
x = ActiveCell.Row
y = ActiveCell.Column
en = [A1048576].End(3).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While i <= en
    i = i + 1
    For n = i + 1 To en
        If Cells(i, y) <> Cells(n, y) Or n = en Then
            n = IIf(n = en, en, n - 1)
            Range(Cells(i, y), Cells(n, y)).Merge
            i = n
            Exit For
        End If
    Next
Loop
Columns(y).VerticalAlignment = xlCenter
End Sub


Sub 港口组_合并亏耗()
Dim en&, i&, n&, y&, num&, sumr As Single, sumw As Single, newKH As Single
num = 3 '合并前3列
en = [A1048576].End(3).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
result = MsgBox("请确认:" & vbCrLf & "1、表头顺序为 船名、批次、油种,并已经排序" & vbCrLf & "2、亏耗数据默认写入AC列,请【删除】列" & vbCrLf & "3、亏耗自行排序及设置百分比", 1, "港口组消息")
    If (result = vbOK) Then
        Do While y < num
            y = y + 1
            i = 1
            Do While i <= en
                i = i + 1
                For n = i + 1 To en
                    If Cells(i, y) <> Cells(n, y) Or n = en Then
                        n = IIf(n = en, en, n - 1)
                        Range(Cells(i, y), Cells(n, y)).Merge
                        '开始计算 根据批次,第2列,计算 w23/r18列 亏耗
                        If y = 1 Then
                            sumr = WorksheetFunction.Sum(Range("R" & i & ":R" & n))
                            sumw = WorksheetFunction.Sum(Range("W" & i & ":W" & n))
                            If (sumw <> 0) Then
                                newKH = sumw / sumr
                                'newKH = Format(newKH, "Percent")
                            Else
                                newKH = 0
                            End If
                            Range("AC" & i & ":AC" & n).Value = newKH
                            Range("AC" & i & ":AC" & n).Merge
                        End If
                        '结束计算
                        i = n
                        Exit For
                    End If
                Next
            Loop
            Columns(y).VerticalAlignment = xlCenter
            Columns("ac").NumberFormatLocal = "0.000%"
        Loop
    Else
       ' MsgBox ("操作取消")
    End If
End Sub




 

发表评论

此站点使用Akismet来减少垃圾评论。了解我们如何处理您的评论数据