統計在vba中合併多少行

Question

我已經創建了一個宏，用於合併D列中包含相同值的行並提供合併行的平均值。我正在嘗試在下面提供的代碼中編寫一行代碼，這些代碼將統計已合併的單個行，並將結果粘貼到合併行（列Q）旁邊，因爲它可以使圖片光澤。圖片1包含初始表格，圖片2包含統一表格。 有什麼想法？非常感激！

更新！

這些更新的圖片

整個過程是完美的，直到Q列（這是更新前的最後一列）。我向目標表中添加了三個列，並向源表再添加了三個列。如果可能，我希望列R宏可以合併行，並打印它們傳遞到列R的平均總WFR。如果列我的行是0.此外，我想讓宏計算它合併的這些行（包含0）（就像它爲列Q一樣），並在列S中打印數字。最後，如果可以計算這些行數（包含0）不在TARGET中，並在列K中輸出數字。我的目標是對於這些行K（值）-E（值）> 3％。

守則最後修訂

昏暗的WS作爲工作表 昏暗dataRng作爲範圍 昏暗DIC爲Variant，編曲爲Variant 昏暗CNT只要

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