| keynote1 - Copy.xlsm | |||
|---|---|---|---|
| A | |||
| 1 | |||
| 2 | Colour string with VBA | ||
| 3 | |||
| 4 | VBA: Color all emails. 12345&@1_2@co.cn if any in cells xyz@wzy.com xyz@wzy.com of column A to green. | ||
| 5 | |||
| 6 | |||
| 7 | |||
| 8 | I have thousands of 12345&@1_2@co.cn rows with emails in the cells of column A. xyz@wzy.com | ||
| 9 | |||
| 10 | |||
| 11 | How can I force color all emails 12345&@1_2@co.cn in green and copy 12345&@1_2@co.cn them into respective rows of column B? 12345&@1_2@co.cn | ||
Input | |||
| keynote1 - Copy.xlsm | ||||
|---|---|---|---|---|
| A | B | |||
| 1 | ||||
| 2 | ||||
| 3 | VBA: Color all emails. 12345&@1_2@co.cn if any in cells xyz@wzy.com xyz@wzy.com of column A to green. | 12345&@1_2@co.cn, xyz@wzy.com, xyz@wzy.com | ||
| 4 | ||||
| 5 | ||||
| 6 | ||||
| 7 | I have thousands of 12345&@1_2@co.cn rows with emails in the cells of column A. xyz@wzy.com | 12345&@1_2@co.cn, xyz@wzy.com | ||
| 8 | ||||
| 9 | ||||
| 10 | How can I force color all emails 12345&@1_2@co.cn in green and copy 12345&@1_2@co.cn them into respective rows of column B? 12345&@1_2@co.cn | 12345&@1_2@co.cn, 12345&@1_2@co.cn, 12345&@1_2@co.cn | ||
Output | ||||
Sub ColourEmailsAndCopy()
Dim a As Variant, b As Variant, Bits As Variant, Bit As Variant
Dim i As Long, p As Long
Application.ScreenUpdating = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
a = .Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
p = 1
Bits = Split(a(i, 1))
For Each Bit In Bits
If InStr(1, Bit, "@") > 0 Then .Cells(i).Characters(p, Len(Bit)).Font.Color = vbGreen
p = p + Len(Bit) + 1
Next Bit
b(i, 1) = Join(Filter(Bits, "@"), ", ")
Next i
With .Offset(, 1)
.Value = b
.Font.Color = vbGreen
End With
End With
Application.ScreenUpdating = True
End Sub
