Sub CopyInto_B()
    Dim lastrow As Long, writerow As Long
    Dim i As Long
    
With Sheets("Sheet1")
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    writerow = 1
    For i = 1 To lastrow
        If .Cells(i, 1).Value <> "" And .Cells(i, 1).Value <> "," Then
            .Cells(writerow, 2).Value = .Cells(i, 1).Value
            writerow = writerow + 1
        End If
    Next i
End With
End Sub