![根据相似内容合并多个 Excel 行,然后在 VBA 中增加一列](https://linux22.com/image/1467718/%E6%A0%B9%E6%8D%AE%E7%9B%B8%E4%BC%BC%E5%86%85%E5%AE%B9%E5%90%88%E5%B9%B6%E5%A4%9A%E4%B8%AA%20Excel%20%E8%A1%8C%EF%BC%8C%E7%84%B6%E5%90%8E%E5%9C%A8%20VBA%20%E4%B8%AD%E5%A2%9E%E5%8A%A0%E4%B8%80%E5%88%97.png)
答案1
将此代码插入模块中,在使用它之前更改变量数量列到您拥有的列号数量标题:
Sub customgroup()
Dim a As Application
Dim wkb As Workbook
Dim wks As Worksheet
Dim DataRange As Range
Set a = Application
Set wkb = ThisWorkbook
Set wks = wkb.Sheets(1)
wks.Application.ScreenUpdating = False
qtycolumn = 4 'this have to be changed to the QTY column
reviewing = True
visitrow = 1
While reviewing = True
visitrow = visitrow + 1
If wks.Cells(visitrow, 1) = "" Then
reviewing = False
End If
If wks.Cells(visitrow, qtycolumn) <> 0 Then
countitems = 1
visitrow2 = visitrow + 1
reviewing2 = reviewing
While reviewing2 = True
If wks.Cells(visitrow2, 1) = "" Then
reviewing2 = False
End If
If wks.Cells(visitrow2, qtycolumn) <> 0 Then
compareranges = Join(a.Transpose(a.Transpose(wks.Rows(visitrow).Value)), Chr(0)) = Join(a.Transpose(a.Transpose(wks.Rows(visitrow2).Value)), Chr(0))
If compareranges = True Then
countitems = countitems + wks.Cells(visitrow2, qtycolumn)
wks.Cells(visitrow2, qtycolumn) = 0
End If
End If
visitrow2 = visitrow2 + 1
Wend
wks.Cells(visitrow, qtycolumn) = countitems
End If
Wend
visitrow = visitrow - 1
LastColumn = wks.Range("A1").CurrentRegion.Columns.Count
Set DataRange = Range(Cells(1, 1), Cells(visitrow, LastColumn))
lettercolumn = Split(Cells(, qtycolumn).Address, "$")(1)
DataRange.Sort key1:=Range(lettercolumn & ":" & lettercolumn), order1:=xlDescending, Header:=xlYes
For i = visitrow To 2 Step -1
filterqty = wks.Cells(i, qtycolumn)
If filterqty = 0 Then
wks.Rows(i).Delete
End If
Next i
wks.Application.ScreenUpdating = True
End Sub