Sub test()
    Dim i As Long, rng1 As Range, rng2 As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For i =  2  To .[A65536].End(xlUp).Row
            If .Cells(i,  1 ).Font.Bold = False Then
                If rng1 Is Nothing Then Set rng1 = .Cells(i,  1 ) _
                    Else Set rng1 = Union(rng1, .Cells(i,  1 ))
            Else
                If rng2 Is Nothing Then Set rng2 = .Cells(i,  1 ) _
                    Else Set rng2 = Union(rng2, .Cells(i,  1 ))
            End If
        Next i
        rng1.Copy .Cells( 2 ,  2 )
        rng2.Copy .Cells( 2 ,  3 )
    End With
    Application.ScreenUpdating = True
End Sub

Sub a1()
    Dim c As Range, j As Long, mtx() As String
    Dim i As Integer, s1 As String, s2 As String, cnt As Long
    
    Application.ScreenUpdating = False
    With ActiveSheet
        Set rng = Intersect(.Range("A:A"), .UsedRange)
    End With
    
    cnt = rng.Rows.Count
    ReDim mtx(cnt -  1 ,  1 ) As String
    
    For j =  1  To cnt
        s1 = "": s2 = ""
        For i =  1  To Len(rng( 1 ).Text)
            If rng(j).Characters(i,  1 ).Font.Bold Then
                s1 = s1 & rng(j).Characters(i,  1 ).Text
            Else
                s2 = s2 & rng(j).Characters(i,  1 ).Text
            End If
        Next
        mtx(j -  1 ,  1 ) = s2
        mtx(j -  1 ,  0 ) = s1
    Next j
    rng.Resize(,  2 ).Value = mtx
End Sub