How to swap text between 2 columns?

[rgr]

I have 2 columns of text. The text may have any number of red fonts or black fonts in either column. I would like to take any of the black fonts in column H and swap it with any of the red fonts in column B. Once column H is full of red fonts the procedure should stop. There may be an overabundance of red fonts in B, or, there may be none.

The code I have works only for the 1st instance then fails. I have attached a screen shot. Thank you for your suggestions.

[VBA]Sub SwapHost()
Dim cel1 As Range
Dim cel2 As Range
Dim rng1 As Range
Dim rng2 As Range
Dim player1 As String
Dim player2 As String
Dim player3 As String
Dim player4 As String
Dim lr As Long
lr = Worksheets("Round 2").Range("B65536").End(xlUp).Row
Set rng1 = Worksheets("Round 2").Range("B5:B36")
Set rng2 = Worksheets("Round 2").Range("H5:H36")

For Each cel1 In rng1
If cel1.Font.ColorIndex = 3 Then
player1 = cel1.Value
For Each cel2 In rng2
If cel2.Font.ColorIndex <> 3 Then
cel2.Value = player1

End If
Next cel2
End If
Next cel1
End Sub[/VBA]

[OBP]

I can't see anything obviously wrong witht the code, can you copy those ranges on to a sheet and post it here so that we can see it in action?
Have you tried putting msgboxes in the code after the if statements to see what the values are that are being found by the code?

[jindon]

not sure about your exact requirement
try

Sub test()
Dim r As Range, rng1() As Range, rng2() As Range
Dim i, ii, x
For Each r In Range("b5:b12")
    If r.Font.Color = vbRed Then
        ReDim Preserve rng1(i)
        Set rng1(i) = r
        i = i + 1
    End If
Next
For Each r In Range("h5:h12")
    If r.Font.Color = vbBlack Then
        ReDim Preserve rng2(ii)
        Set rng2(ii) = r
        ii = ii + 1
    End If
Next
If i = Empty Or ii = Empty Then Exit Sub
x = Application.Min(i, ii)
x = x - 1
For i = 0 To x
    temp = rng1(i).Value
    rng2(i).Copy rng1(i)
    rng2(i).Value = temp
    rng2(i).Font.Color = vbRed
Next
End Sub