vba - 计算在vba中合并了多少行

Question

我创建了一个宏，用于合并 D 列中包含相同值的行，并提供合并行的平均值。我正在尝试在下面提供的代码中编写一行代码，它将计算已合并的各个行并将结果粘贴到合并行(Q 列)旁边，因为它可以从图片中显示出来。图 1 包含初始表，图 2 包含合并表。
有任何想法吗？非常感激!

更新!

这些是更新的图片



整个过程是完美的，直到第 Q 行(它是更新前的最后一列)。我在目标表中添加了三列，在源表中添加了另外一列。如果可能，我希望列 R 宏合并行并打印它们的平均总 WFR 传递到列 R 仅当列该行的 I 为 0。此外，我希望宏计算它合并的这些行(包含 0)(就像它对 Q 列所做的那样)并在 S 列中打印数字。最后，如果可以计算这些行数(包含 0)超出 TARGET 并打印列 K 中的数字。我所说的 out of TARGET 的意思是这些行的 K(values)-E(values)>3%。

代码的最终更新

暗淡为工作表
将数据调暗为范围
Dim dic 作为变体，arr 作为变体
变暗只要

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