Modify VBA to select Cells with Red Font Copy only cells not row

[baz9d93]

Thank you for taking time to read this

I am wotking with a tutorial first time using VBA

At the moment it works when All the text in the row has red font - I need it so that

1. It only selects the cells with red font and copy those only NOT the entire row and also put the cell in same position on the new sheet it copies to.
2. Also copy into new sheet the code value in the row Col A see mockup image

Sub CopyColouredFontTransactions()

Dim TransIDField As Range
Dim TransIDCell As Range
Dim ATransWS As Worksheet
Dim HTransWS As Worksheet
Dim x As Long

Set ATransWS = Worksheets("All Transactions")
Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
Set HTransWS = Worksheets("Highlighted Transactions")


For Each TransIDCell In TransIDField

    If TransIDCell.Font.Color = RGB(255, 0, 0) Then
       
        TransIDCell.Resize(1, 10).Copy Destination:= _
            HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
           
    End If

Next TransIDCell

HTransWS.Columns.AutoFit

End Sub

 

[Z51]

Perhaps this will work...

Sub baz9d93()
Dim ce As Range, lastrow As Long, lastcol As Long, i As Long
Dim wsA As Worksheet, wsH As Worksheet

Set wsA = Sheets("All Transactions")
Set wsH = Sheets("Highlighted Transactions")

lastrow = wsA.Range("A" & Rows.Count).End(xlUp).Row
lastcol = wsA.Cells.SpecialCells(xlCellTypeLastCell).Column
Application.ScreenUpdating = False

For Each ce In wsA.Range(wsA.Cells(2, 2), wsA.Cells(lastrow, lastcol))
    If ce.Font.Color = RGB(255, 0, 0) Then
        ce.Copy wsH.Range(ce.Address)
        wsH.Range("A" & ce.Row).Value = wsA.Range("A" & ce.Row).Value
    End If
Next ce

lastrow = wsH.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow
    If wsH.Cells(i, 1).Value = "" Then wsH.Cells(i, 1).EntireRow.Delete
Next i

wsH.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

[baz9d93]

Perhaps this will work...

Sub baz9d93()
Dim ce As Range, lastrow As Long, lastcol As Long, i As Long
Dim wsA As Worksheet, wsH As Worksheet

Set wsA = Sheets("All Transactions")
Set wsH = Sheets("Highlighted Transactions")

lastrow = wsA.Range("A" & Rows.Count).End(xlUp).Row
lastcol = wsA.Cells.SpecialCells(xlCellTypeLastCell).Column
Application.ScreenUpdating = False

For Each ce In wsA.Range(wsA.Cells(2, 2), wsA.Cells(lastrow, lastcol))
    If ce.Font.Color = RGB(255, 0, 0) Then
        ce.Copy wsH.Range(ce.Address)
        wsH.Range("A" & ce.Row).Value = wsA.Range("A" & ce.Row).Value
    End If
Next ce

lastrow = wsH.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow
    If wsH.Cells(i, 1).Value = "" Then wsH.Cells(i, 1).EntireRow.Delete
Next i

wsH.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Thank you for your quick reply this is working correctly thanks but 1 thing I notice if Col A does not have have Code but other cells in that row do have text with red font they dont get copied over. Can this be done?

Also - as I mentioned I am new to VBA and this was from a basic tutorial I was learning from - but in the actual worksheet that I have it has 35000 rows and 60 Columns with different values - the way I am doing it now is using Find Replace entering the Word I need to find - in each cell - then CTRL A - then changing the font color to Red then using this Code you have kindly provided. So I need to run this process 60 times

Is it possible for me to get this done faster by putting in Sheet 1 in another Column for example Col E all the values I need it to look for and then Put them each in a new Sheet?

Or can anyone kindly suggest a more efficient way of doing this task. thank you

 

[Z51]

My code deletes all rows on the results sheet where column A is blank (I didn't realize you'd have a row of data without a code in the first column), so just remove this portion of the code and it should keep all rows where red font is encountered:

For i = 2 To lastrow
    If wsH.Cells(i, 1).Value = "" Then wsH.Cells(i, 1).EntireRow.Delete
Next i

 

[Z51]

Also, I'd recommend putting your additional functionality requests in a new post.

 

[baz9d93]

Also, I'd recommend putting your additional functionality requests in a new post.

Thank you very much for your help with this really appreciate it - i will create a new post as you kindly suggested. Much Appreciated