如何在重复删除VBA之前在其余单元格中添加其他数据？

我有下面的表格，我需要格式化和删除重复项，但不能解决如何更新列G来添加属于该副本的所有灯具在删除重复项后保留的一行上，在括号中我需要的数量（1），10001（5），10002（1），10003（10）。

Sub RemoveDuplicates() Dim checkLastRow As Long, r1 As Long Dim DeleteRange As Range On Error GoTo ErrorHandler Application.ScreenUpdating = False CopySheet With Worksheets("Edited") checkLastRow = .Range("D" & .Rows.Count).End(xlUp).Row For r1 = 6 To checkLastRow If .Cells(r1, 4).Value = Cells(r1 + 1, 4).Value Then If DeleteRange Is Nothing Then Set DeleteRange = .Rows(r1) Else Set DeleteRange = Union(DeleteRange, .Rows(r1)) End If End If Next r1 If Not DeleteRange Is Nothing Then DeleteRange.Delete End With Range("A:K").UnMerge Range("H6:K6").Delete shift:=xlUp DeleteBlankRows Range("A1:K4").Merge True UpdateScreen: Application.ScreenUpdating = True Exit Sub ErrorHandler: Debug.Print Err.Number; Err.Description MsgBox "Sorry, an error occured." & vbCrLf & Err.Description, vbCritical, "Error!" Resume UpdateScreen End Sub Private Sub CopySheet() Dim MySheetName As String MySheetName = "Edited" Sheets(1).Copy After:=Sheets(1) ActiveSheet.Name = MySheetName End Sub Private Sub DeleteBlankRows() Dim r As Long Dim DeleteRange As Range Dim lastRow As Long With Worksheets("Edited") lastRow = .Range("D" & .Rows.Count).End(xlUp).Row For r = 6 To lastRow If Application.WorksheetFunction.CountA(Range("A" & r & ":" & "D" & r)) = 0 Then If DeleteRange Is Nothing Then Set DeleteRange = Rows(r) Else Set DeleteRange = Union(DeleteRange, Rows(r)) End If End If Next r If Not DeleteRange Is Nothing Then DeleteRange.Delete shift:=xlUp End With End Sub 

Answer 1

这是一种方法。 在您的示例文件上testing它花费了不到一秒的时间。 它看起来很大，因为评论:)

 Option Explicit Sub Sample() Dim ws As Worksheet Dim delRange As Range Dim lRow As Long, i As Long Set ws = ActiveSheet With ws lRow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Delete All rows where Cell A and Cell B are empty For i = 6 To lRow If Len(Trim(.Range("A" & i).Value)) = 0 Or Len(Trim(.Range("B" & i).Value)) = 0 Then If delRange Is Nothing Then Set delRange = .Rows(i) Else Set delRange = Union(delRange, .Rows(i)) End If End If Next i If Not delRange Is Nothing Then delRange.Delete '~~> Find the new last row lRow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Insert a new column between G and H .Columns(8).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '~~> Insert a formula =G6 & "(" & I6 & ")" in H6 '~~> Inserting the formula in the entire column in one go '~~> and converting it to values .Range("H6:H" & lRow).Formula = "=G6 & ""("" & I6 & "")""" .Range("H6:H" & lRow).Value = .Range("H6:H" & lRow).Value '~~> Copy the header from Col G to Col H so that we can delete the '~~> Column G as it is not required anymore .Range("H5").Value = .Range("G5").Value .Columns(7).Delete '~~> Using a reverse loop to append values from bottom row to the row above '~~> After appending clear the cell G so that we can later delete the row For i = lRow To 7 Step -1 If .Range("F" & i).Value = .Range("F" & i - 1).Value Then .Range("G" & i - 1).Value = .Range("G" & i - 1).Value & "," & .Range("G" & i).Value .Range("H" & i - 1).Value = .Range("H" & i - 1).Value + .Range("H" & i).Value .Range("G" & i).ClearContents End If Next i Set delRange = Nothing '~~> Delete rows where Cell G is empty For i = 6 To lRow If Len(Trim(.Range("G" & i).Value)) = 0 Then If delRange Is Nothing Then Set delRange = .Rows(i) Else Set delRange = Union(delRange, .Rows(i)) End If End If Next i If Not delRange Is Nothing Then delRange.Delete '~~> Find the new last row lRow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Calculating the variance .Range("J6:J" & lRow).Formula = "=H6-I6" .Range("J6:J" & lRow).Value = .Range("J6:J" & lRow).Value End With End Sub