Номер нежелательной почты после выполнения кода vba

Question

У меня есть код, который копирует номера (которые не имеют цвета) из диапазона (здесь D3 - D30) и вставляет его в столбец F, смотрящий из строки 1, и делает некоторый процентиль расчет.

Проблема в том, что в первом столбце F в первом столбце появляется случайное число «5», хотя в моем диапазоне D3-D30 такого номера нет.

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 не установлен.