0

我正在编写一个宏，它将用于合并来自一系列单元格的数据。我有一个表格，其中包含要在 Range D2:J6 中的 sheet("1") 中合并的数据，并且目标位置再次在 M2:R2 中的 sheet("1") 中（列 M 到 R，但它们包含标题）。我已经编写了下面的部分代码，它适用于它们并为它们运行。但是，即使它没有说它有错误，它也不会正确运行..宏运行后我正在从我的 excel 中截取屏幕截图..

正如您从图像中看到的那样，我想合并 D 行中的重复值，并将位于 E、F、G、H、I、J 列中的值的平均值打印在与 D 列中的合并值相同的行上. 例如，对于 D 列中的值“Gebze 6832”，我想将其作为重复项删除，使其成为目标中的一个单元格，并打印列 E、F、G、H、I、J 的平均值在目标列中合并在其旁边的两行。

我的代码如下（更新）

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 & ","""")"
.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($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),"""")"
Next i
.Range("M" & i).Value = "Grand Total"
.Range("N" & i & ":P" & i).Formula = "=AVERAGE(N2:N" & cnt + 1 & ")"
.Range("Q" & i).Formula = "=SUM(Q2:Q" & cnt + 1 & ")"
.Range("R" & i).Formula = "=AVERAGE(R2:R" & cnt + 1 & ")"
.Range("S" & i & ":T" & i).Formula = "=SUM(S2:S" & 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
4

1 回答 1

1

假设您的数据在从以下Column D to Column J开始的范围内并且必须从以下开始Row 2显示输出可能会有所帮助。Column M to Column SRow 2

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
        cnt = dic.Count
        For i = 2 To cnt + 1
            .Range("N" & i & ":S" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
        Next i
        .Range("N2:S" & .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

此代码将给出以下结果。

在此处输入图像描述

于 2017-08-25T12:15:33.323 回答