Sub T()
    Dim arrIn, arrOut, lngI As Long, lngJ As Long, lngK As Long
    Range("F1").CurrentRegion.ClearContents
    arrIn = Range("A1").CurrentRegion.Value
    ReDim arrOut(1 To UBound(arrIn, 1) * UBound(arrIn, 2), 1 To 1)
    For lngI = 1 To UBound(arrIn, 1)
        For lngJ = 1 To UBound(arrIn, 2)
            If arrIn(lngI, lngJ) <> "" Then
                lngK = lngK + 1
                arrOut(lngK, 1) = arrIn(lngI, lngJ)
            End If
        Next lngJ
    Next lngI
    Range("F1").Resize(lngK, 1) = arrOut
End Sub

=ЕСЛИ(D2<>ИСТИНА;ЕСЛИ((ДЕНЬ(СЕГОДНЯ())-ДЕНЬ(A2))<0;"До заказа "&(СЕГОДНЯ()-A2)*-1 &" д"&ТЕКСТ(ОСТАТ(МАКС(ОСТАТ(((ДЕНЬ(СЕГОДНЯ())-ДЕНЬ(A2))*-1)-11;100);9);10);"[<1]ень;[<4]ня;ней");ЕСЛИ((СЕГОДНЯ()-A2)=0;"СЕГОДНЯ день заказа";"ПРОСРОЧЕНО"));"Оплачено")

Sub T_723()
    Dim lngI As Long, lngJ As Long, intI As Integer, arrS, whIn As Worksheet, whOut As Worksheet
    Set whIn = Worksheets("есть"): Set whOut = Worksheets("надо")
    With whOut
        If .Range("A9").CurrentRegion.Rows.Count > 1 Then
            .Range("A9").CurrentRegion.Offset(1, 0).Resize(.Range("A9").CurrentRegion.Rows.Count - 1, 2).ClearContents
        End If
    End With
    With whIn
        lngJ = 9
        For lngI = 10 To .Cells(Rows.Count, 1).End(xlUp).Row
            arrS = Split(.Cells(lngI, 1), ",")
                For intI = 0 To UBound(arrS, 1)
                    lngJ = lngJ + 1
                    whOut.Cells(lngJ, 1) = arrS(intI): whOut.Cells(lngJ, 2) = .Cells(lngI, 2)
                Next intI
            Erase arrS
        Next lngI
    End With
    
End Sub 

Sub T()
Dim strS As String, strO As String, strI As String, intI As Integer, lngI As Long
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Pattern = "\+7\s?[(]?\d{3}[)]?\s?\d{3}-\d{2}-\d{2}"
objRegExp.Global = True
    'чистим столбец F
    Range("F2").CurrentRegion.ClearContents
    'циклом бегаем по всем ИНН из столбца А и находим их значения в столбце H
    'забираем значения из столбца К (телефоны) по найденной строке на обработку
    For lngI = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        strI = Range("A" & lngI).Value
        'если значение ИНН не нашли в перечне - ругаемся и выходим
        If Range("H1").CurrentRegion.Find(strI) Is Nothing Then
            MsgBox ("Значение ИНН " & Range("A" & lngI) & " нет в перечне ИНН")
            Exit Sub
        End If
        'меняем в найденных телефонах все скобки на ничего
        strS = Range("H1").CurrentRegion.Find(strI).Offset(0, 3).Value
        strS = Replace(strS, "(", "")
        strS = Replace(strS, ")", "")
        'по заданному шаблону проверяем номера телефонов. Если встречается код 455, 499 - не пишем в итоговую строку
        Set objMatches = objRegExp.Execute(strS)
        For intI = 0 To objMatches.Count - 1
            If InStr(1, objMatches.Item(intI), "+7 495") = 0 And InStr(1, objMatches.Item(intI), "+7 499") = 0 Then
                strO = strO & objMatches.Item(intI) & ",|"
            End If
        Next intI
        'если итоговая строка не пустая, пишем в столбец F значения теелфонов, разделенные запятыми и переносом
        If Not strO = "" Then
            strO = Left(strO, Len(strO) - 2)
            Range("F" & lngI) = Replace(strO, "|", Chr(10))
            strO = ""
        End If
    Next lngI 'и так бегаем циклом пока в столбце А не кончатся данные
End Sub

Sub T()
    Dim arrIn, arrOut, arrS, lngI As Long, lngJ As Long, lngK As Long, intN As Integer
    arrIn = [b2].CurrentRegion.Value
    ReDim arrOut(1 To (UBound(arrIn, 1) - 1) * 2, 1 To 5)
    For lngI = 2 To UBound(arrIn, 1)
        lngK = lngK + 2
        arrS = Split(arrIn(lngI, 4), ",")
        For lngJ = 0 To UBound(arrS)
            If Val(arrS(lngJ)) Mod 2 = 0 Then
                arrOut(lngK - 1, 1) = arrIn(lngI, 1): arrOut(lngK - 1, 2) = arrIn(lngI, 2): arrOut(lngK - 1, 3) = arrIn(lngI, 3)
                arrOut(lngK - 1, 4) = arrOut(lngK - 1, 4) & arrS(lngJ) & ", ": arrOut(lngK - 1, 5) = 2
            Else
                arrOut(lngK, 1) = arrIn(lngI, 1): arrOut(lngK, 2) = arrIn(lngI, 2): arrOut(lngK, 3) = arrIn(lngI, 3)
                arrOut(lngK, 4) = arrOut(lngK, 4) & arrS(lngJ) & ", ": arrOut(lngK, 5) = 1
            End If
        Next lngJ
    Next lngI
    lngJ = Cells(Rows.Count, 2).End(xlUp).Row + 4
    [b2:f2].Copy Range("B" & lngJ - 1)
    Range("b" & lngJ).Resize(lngK, 5) = arrOut
End Sub