vbaで連結される行数をカウントします

Question

列Dに同じ値を含む行を統合し、連結された行の平均を提供するマクロを作成しました。私は統合された個々の行を数え、結果を貼り付けられた行（列Q）の隣に貼り付けるコードを、以下のコードの中に記述しようとしています。ピクチャ1は初期テーブルを含み、ピクチャ2は統合テーブルを含む。 アイデア？とても有難い！

UPDATE！

これらは、全体のプロセスは、行Q（それは更新前の最後の列だった）までPERFECTで更新画像

です。可能であれば、列Rに行を統合し、その列に平均ROWを渡して印刷するようにします。また、（列Qの場合と同様に）整列されたこれらの行（0を含む）を数え、列Sに数値を出力するようにします。最後に、 TARGETから外れているこれらの行の数（0を含む）を取得し、列Kに番号を出力します.TARGETの意味は、これらの行K（値）-E（値）> 3％です。 CODE OF

FINAL UPDATEバリアントとしてワークシート 薄暗いdataRngとしてレンジ 薄暗いDICとして

薄暗いWSは、バリアント としてARRロング

として暗い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になります。

EDIT：

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 

EDIT 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 

EDIT 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