T3946_Transfer Numbers By Column Rank

https://excel-egy.com/forum/t3946
---------------------------------

Sub Transfer_Numbers_By_Column_Rank()
    Dim x, c As Range, rng As Range, m As Long, r As Long

    Application.ScreenUpdating = False
        With Range("F1").CurrentRegion.Offset(2, 1)
            .Value = Empty
            .Font.ColorIndex = xlAutomatic
            .Interior.Color = xlNone
            .Borders.Value = 0
        End With

        x = Application.Match(Range("F3").Value, Columns(1), 0)
        r = 3

        If Not IsError(x) Then
            m = IIf(Cells(x, 1).End(xlDown).Row = Rows.Count, Cells(x, 2).End(xlDown).Row + 1, Cells(x, 1).End(xlDown).Row)
            Set rng = Range(Cells(x, 2), Cells(m - 1, 2))

            For Each c In rng
                If Len(c.Value) = 6 Then
                    r = r + 4
                    Cells(r - 1, "I").Value = c.Value
                    Cells(r - 2, "I").Value = Left(c.Value, 5): Cells(r - 2, "I").Font.Color = vbRed
                    Cells(r - 3, "H").Value = Left(c.Value, 4): Cells(r - 3, "H").Font.Color = vbRed
                    Cells(r - 4, "G").Value = Left(c.Value, 3): Cells(r - 3, "H").Font.Color = vbRed
                ElseIf Len(c.Value) = 5 Then
                    r = r + 3
                    Cells(r - 1, "I").Value = c.Value
                    Cells(r - 2, "H").Value = Left(c.Value, 4): Cells(r - 2, "H").Font.Color = vbRed
                    Cells(r - 3, "G").Value = Left(c.Value, 3): Cells(r - 3, "G").Font.Color = vbRed
                ElseIf Len(c.Value) = 4 Then
                    r = r + 2
                    Cells(r - 1, "H").Value = c.Value
                    Cells(r - 2, "G").Value = Left(c.Value, 3): Cells(r - 2, "G").Font.Color = vbRed
                ElseIf Len(c.Value) = 3 Then
                    r = r + 1
                    Cells(r - 1, "G").Value = c.Value
                End If
            Next c
        End If

        For r = Range("F1").CurrentRegion.Rows.Count To 3 Step -1
            If Cells(r, 7).Value <> "" And Application.CountIf(Range("G3:G" & r), Cells(r, 7).Value) > 1 _
            Or Cells(r, 8).Value <> "" And Application.CountIf(Range("H3:H" & r), Cells(r, 8).Value) > 1 _
            Or Cells(r, 9).Value <> "" And Application.CountIf(Range("I3:I" & r), Cells(r, 9).Value) > 1 _
            Then Cells(r, 7).Resize(1, 3).Delete
        Next r

        With Range("G3:I" & Range("F3").CurrentRegion.Rows.Count)
            .Interior.Color = vbYellow
            .Borders.Value = 1
        End With
    Application.ScreenUpdating = True
End Sub