统计在vba中合并了多less行

我创build了一个macros来合并D列中包含相同值的行，并提供合并的行的平均值。 我试图在下面提供的代码中编写一行代码，它将统计已合并的单个行，并将结果粘贴到统一行（列Q）旁边，因为它可以使图片更加光滑。 图1包含初始表，图2包含统一表。 有任何想法吗？ 非常感激！

UPDATE！

这些是更新的图片

整个过程是完美的，直到Q行（这是更新之前的最后一列）。 我向目标表中添加了三个列，还向源表中添加了三个列。如果可能的话，我需要列Rmacros来合并行并打印它们的平均总WFR，如果列我的行是0.另外，我想让macros来统计这些行（包含0），它合并（就像它为列Q），并在列S列印数字。最后，如果有可能计数这些行的数量（包含0）不在TARGET中，并在列K中打印出数字。我的目标是指对于这些行K（值）-E（值）> 3％。

最后更新的代码

Dim ws As Worksheet Dim dataRng As Range Dim dic As Variant，arr As Variant Dim cnt As Long

Set ws = Sheets("1") With ws lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D Set dataRng = .Range("D2:D" & lastrow) 'range for Column D Set dic = CreateObject("Scripting.Dictionary") arr = dataRng.Value For i = 1 To UBound(arr) dic(arr(i, 1)) = dic(arr(i, 1)) + 1 Next .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items) cnt = dic.Count For i = 2 To cnt + 1 .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastrow & ",$M" & i & ",E$2:E$" & lastrow & ")/" & dic(.Range("M" & i).Value) .Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,N" & i & ",0)" .Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,Q" & i & ",0)" .Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),0)" Next i .Range("N" & i & ":T" & i).Formula = "=SUM(N2:N" & cnt + 1 & ")" .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value End With 

Answer 1

尝试这个：

 Sub Demo() Dim ws As Worksheet Dim dataRng As Range Dim dic As Variant, arr As Variant Dim cnt As Long Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet Application.ScreenUpdating = False With ws lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D Set dataRng = .Range("D2:D" & lastRow) 'range for Column D Set dic = CreateObject("Scripting.Dictionary") arr = dataRng.Value For i = 1 To UBound(arr) dic(arr(i, 1)) = dic(arr(i, 1)) + 1 Next .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items) 'count of shipment cnt = dic.Count For i = 2 To cnt + 1 .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value) Next i .Range("N2:P" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value End With Application.ScreenUpdating = True End Sub 

假设：您的数据在范围Column D:ColumnG并希望在Column M:ColumnQ输出。

编辑：

 Sub Demo() Dim ws As Worksheet Dim dataRng As Range Dim dic As Variant, arr As Variant Dim cnt As Long Set ws = ThisWorkbook.Sheets("Sheet5") 'change Sheet4 to your data sheet Application.ScreenUpdating = False With ws lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D Set dataRng = .Range("D2:D" & lastRow) 'range for Column D Set dic = CreateObject("Scripting.Dictionary") arr = dataRng.Value For i = 1 To UBound(arr) dic(arr(i, 1)) = dic(arr(i, 1)) + 1 Next .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items) cnt = dic.Count For i = 2 To cnt + 1 .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value) .Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,N" & i & ","""")" .Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,Q" & i & ","""")" .Range("T" & i).Formula = "=IF(ISNUMBER($S" & i & "),SUMPRODUCT(($D$2:$D$" & lastRow & "=$M" & i & ")*(($K$2:$K$" & lastRow & "-$E$2:$E$" & lastRow & ")>3%)),"""")" Next i .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value End With Application.ScreenUpdating = True End Sub 

编辑2：

代替

 .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value 

写

 .Range("N" & i & ":T" & i).Formula = "=SUM(N2:N" & cnt + 1 & ")" .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value 

编辑3：

 Sub Demo_SO() Dim ws As Worksheet Dim dataRng As Range Dim dic As Variant, arr As Variant Dim cnt As Long Set ws = ThisWorkbook.Sheets("Sheet5") 'change Sheet4 to your data sheet Application.ScreenUpdating = False With ws lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D Set dataRng = .Range("D2:D" & lastRow) 'range for Column D Set dic = CreateObject("Scripting.Dictionary") arr = dataRng.Value For i = 1 To UBound(arr) dic(arr(i, 1)) = dic(arr(i, 1)) + 1 Next .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items) cnt = dic.Count For i = 2 To cnt + 1 .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value) .Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,N" & i & ",0)" .Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,Q" & i & ",0)" .Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastRow & "=$M" & i & ")*(($K$2:$K$" & lastRow & "-$E$2:$E$" & lastRow & ")>3%)),0)" Next i .Range("N" & i & ":T" & i).Formula = "=SUM(N2:N" & cnt + 1 & ")" .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value End With Application.ScreenUpdating = True End Sub