Try the attached. Click the button on sheet 1
Assumes that your list is in Column A and Row 1 is a header row.
Since the words in italics are the scientific name there should always be 2 words (or an initial then a word). The common name can be any number of words.
The code will also remove any superfluous spaces.
Code assigned to the button.
Sub SplitName()
Dim x, y, yy, z, i&, ii&
With ActiveSheet
x = .Columns(1).SpecialCells(2)
ReDim y(1 To UBound(x, 1) - 1, 1 To 1)
ReDim yy(1 To UBound(x, 1) - 1, 1 To 1)
For i = 2 To UBound(x, 1)
z = Split(x(i, 1))
For ii = LBound(z) To UBound(z) - 2
If IsEmpty(y(i - 1, 1)) Then
y(i - 1, 1) = Trim(z(ii))
Else
y(i - 1, 1) = y(i - 1, 1) & " " & Trim(z(ii))
End If
Next
yy(i - 1, 1) = Trim(z(UBound(z) - 1)) & " " & Trim(z(UBound(z)))
Next
.[a2].Resize(UBound(y, 1)) = y
With .[b2].Resize(UBound(yy, 1))
.Value = yy
.Font.Italic = 1
End With
.Columns(2).Resize(, 2).AutoFit
End With
End SubHi KjBox
Wow! I am ever so grateful to you for the code, it would have taken me weeks to do it manually as there are almost a thousand row in the sheet. I am compiling a bird ID book for a secondary school, therefore the spli as I have to use the latin name as a lookup reference to translate it into another language.. Thanks SO much.
Cats4711
Couldn't find the LIKE button, but marked your reply as THE 
BEST!
Your welcome. The Like button is the smiley face at the bottom right of the post.
Do you need the colour fill to be included or is that just for clarity of explanation?
No problem, I am in Borneo so 7 hours ahead of you.
Can you explain the logic of why, in your sample, Arend, Gevlekte has a grey fill in the current configuration but no fill in the required result, is it a case of all rows that have an empty cell in Column C have no fill?
Try changing the code to this
Sub SplitName()
Dim x, y, yy, z, i&, ii&
With ActiveSheet
x = .Columns(1).SpecialCells(2)
ReDim y(1 To UBound(x, 1) - 1, 1 To 1)
ReDim yy(1 To UBound(x, 1) - 1, 1 To 2)
For i = 2 To UBound(x, 1)
z = Split(x(i, 1))
If InStr(1, x(i, 1), "(") = 0 Then
For ii = LBound(z) To UBound(z) - 2
If IsEmpty(y(i - 1, 1)) Then
y(i - 1, 1) = Trim(z(ii))
Else
y(i - 1, 1) = y(i - 1, 1) & " " & Trim(z(ii))
End If
Next
yy(i - 1, 1) = Trim(z(UBound(z) - 1)) & " " & Trim(z(UBound(z)))
Else
For ii = LBound(z) To UBound(z) - 3
If IsEmpty(y(i - 1, 1)) Then
y(i - 1, 1) = Trim(z(ii))
Else
y(i - 1, 1) = y(i - 1, 1) & " " & Trim(z(ii))
End If
Next
yy(i - 1, 1) = Trim(z(UBound(z) - 2)) & " " & Trim(z(UBound(z) - 1))
yy(i - 1, 2) = Trim(z(UBound(z)))
End If
Next
.[a2].Resize(UBound(y, 1)) = y
.[b2].Resize(UBound(yy, 1), 2) = yy
.Columns(2).Resize(, 2).AutoFit
With .Cells(1).CurrentRegion.Offset(1).Resize(.Cells(1).CurrentRegion.Rows.Count - 1)
.Columns(1).Copy
.Resize(, 3).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Columns(3).SpecialCells(4).EntireRow.Interior.Color = xlNone
.Columns(2).Font.Italic = 1
.Borders.Weight = 2
End With
Application.Goto .[a1]
End With
End SubYou're welcome
Don’t have an account yet? Register yourself now and be a part of our community!
