vbaコードを実行した後に表示される迷惑メール番号

Question

範囲（ここではD3からD30）の数字（色がない）をコピーし、1行目からF列に貼り付け、計算。

問題は、私の範囲D3 - D30にそのような番号がないのに、最初の行のF列に迷いのある数字 "5"が表示されることに気付きました。

Sub TPNoRedpass50tablet() 

    Dim cel As Range 
    Dim Rng As Range 
    Dim arr As Variant 
    Dim i As Long 
    Application.ScreenUpdating = False 
     For Each cel In Sheets("TP").Range("TP!$D$3:$D$30") 
     If cel.Font.Color = 0 Then 
     If Rng Is Nothing Then 
     Set Rng = cel 
    Else 
     Set Rng = Union(cel, Rng) 
     End If 
     End If 
     Next cel 
     ReDim arr(Rng.count - 1) 
     If Not Rng Is Nothing Then 
      For Each cel In Rng 
       arr(i) = cel 
       i = i + 1 
     Next cel 
    Sheets("TP").Range("F1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr) 
    Set Rng = Sheets("TP").Range("F1:I" & Sheets("TP").Cells(Rows.count, "F").End(xlUp).Row) 
    Sheets("WBR").Range("AH101").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24" 
    Sheets("WBR").Range("AH101").Value = Sheets("WBR").Range("AH101").Value 


     End If 
     Application.ScreenUpdating = True 
End Sub 

Answer 1

これを試してみてください：

Sub TPNoRedpass50tablet() 

    Dim cel As Range 
    Dim Rng As Range 
    Dim arr As Variant 
    Dim i As Long 

    Application.ScreenUpdating = False 
     For Each cel In Sheets("TP").Range("TP!$D$3:$D$30") 
     If Rng Is Nothing Then 
     Set Rng = cel  
     If cel.Font.Color = 0 Then 
    Else 
     Set Rng = Union(cel, Rng) 
     End If 
     End If 
     Next cel 
     ReDim arr(Rng.count - 1) 
     If Not Rng Is Nothing Then 
      For Each cel In Rng 
       arr(i) = cel 
       i = i + 1 
     Next cel 
    Sheets("TP").Range("F1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr) 
    Set Rng = Sheets("TP").Range("F1:I" & Sheets("TP").Cells(Rows.count, "F").End(xlUp).Row) 
    Sheets("WBR").Range("AH101").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24" 
    Sheets("WBR").Range("AH101").Value = Sheets("WBR").Range("AH101").Value 


     End If 
     Application.ScreenUpdating = True 
End Sub 

問題は各ループの最初であると思われます。あなたは組合を持っています、これはRngが設定されていない初めての時だけ実行されます。