VBA:合并具有相同ID号的单元格

时间:2016-11-07 21:39:57

标签: excel vba

基本上,我想创建一个宏,它将SUM列合并为相同的连续ID。在条件格式中,类似于:= OR(A1 = A2; A2 = A3),用于C列。

ID   QTY  SUM    >   ID   QTY   SUM
001    1    1    >   001    1     1
002    2    5    >   002    2     5
002    3    5    >   002    3      
003    4    4    >   003    4     4

See Example

我相信它应该非常简单。

非常感谢!

2 个答案:

答案 0 :(得分:0)

这应该可以胜任。

Option Explicit

Private Sub MergeCells()
' Disable screen updates (such as warnings, etc.)
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim rngMerge As Range, rngCell As Range, mergeVal As Range
Dim i As Integer
Dim wks As Worksheet

Set wks = ThisWorkbook.Sheets("Sheet1") ' Change Sheet1 to your worksheet

i = wks.Range("A2").End(xlDown).Row
Set rngMerge = wks.Range("A2:A" & i) ' Find last row in column A

With wks
' Loop through Column A
For Each rngCell In rngMerge
    ' If Cell value is equal to the cell value below and the cell is not empty then
    If rngCell.Value = rngCell.Offset(1, 0).Value And IsEmpty(rngCell) = False Then
        ' Define the range to be merged
        ' Be aware that warnings telling you that the 2 cells contain 2 differen values will be ignored
        ' If you have 2 different sums in column C, then it will use the first of those
        Set mergeVal = wks.Range(rngCell.Offset(0, 2), rngCell.Offset(1, 2))
        With mergeVal
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        End With
    End If
Next
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

答案 1 :(得分:0)

到目前为止,我使用了以下代码:

Sub MergeSum()  
    Set Rng = ActiveSheet.Range("A1:A5")
    Dim nIndex As Long
    Dim iCntr As Long
    For iCntr = 1 To 5
    If Cells(iCntr, 1) <> "" Then
    nIndex = WorksheetFunction.Match(Cells(iCntr, 1), Rng, 0)
    If iCntr <> nIndex Then
    Let Obj = "C" & nIndex & ":" & "C" & iCntr
    Range(Obj).Select
    Application.DisplayAlerts = False
    Selection.Merge
    Application.DisplayAlerts = True
    End If
    End If
    Next
End Sub

但是这段代码有一个限制,它只适用于上升的ID。