Search for fontcolour, copy row to another existing workbook, to sheet with cellvalue-name

Hello there,

I believe the below code should work for you:
*Please note: You will need to change the text I have made red in the code below to the filepath for the Administration workbook on your computer. If you are unsure of the filepath you can always open the workbook and in a blank cell type = CELL("filename") and that should give you the location.

'declare variables
Dim c As Range, LR As String, NLR As String
Dim ExWB As Workbook, AdWB As Workbook, x As String
Dim rng As Range

Set ExWB = ThisWorkbook 'set exwb equal to the exchange directly workbook
    
    'open the Administration workbook,
    'change the below file path to your file path
    
    Application.Workbooks.Open Filename:="C:\Documents and Settings\rvasquez\My Documents\Example Spreadsheets\Test Folder2\Administration.xls"
         
        'set adWB equal to the Administration workbook
        Set AdWB = ActiveWorkbook
    
With ExWB.Sheets(1) 'with the exchange workbook first worksheet in the workbook
    .Activate   'activate the workbook
    LR = .Range("A6555").End(xlUp).Row  'set the variable LR equal to teh last row that contains a value in column A
        For Each c In .Range("A1:A" & LR + 1).Cells 'loop through cells in column A from row 1 to the last row
            If c.Font.Color = RGB(255, 0, 0) Then   'if the font color in the current cell in the loop is red then

                x = .Range("g" & c.Row).Value   'set x equal to value in the current cell in the loop's row in column G
                .Range("A" & c.Row & ":J" & c.Row).Copy 'copy the cells from A to J of the current cell in the loop's row
                
                On Error Resume Next
                
                With AdWB.Sheets(x) 'with the worksheet in the Administrative workbook whose name is equal to x (defined above)
                    NLR = .Range("A6555").End(xlUp).Row + 1 'set NLR equal to the last row in column A the contains a value +1
                    .Range("A" & NLR).PasteSpecial xlPasteValues    'paste the copied values to the first empty cell
                    .Range("A" & NLR & ":J" & NLR).Font.Color = RGB(0, 0, 0)    'turn the font black
                End With
                
                If rng Is Nothing Then  'if the variable rng is nothing then
                    Set rng = .Range(.Cells(c.Row, 1), .Cells(c.Row, 10))   'set rng equal to cells A through J of the current row
                Else: Set rng = Union(rng, .Range(.Cells(c.Row, 1), .Cells(c.Row, 10))) 'if rng does exist then set the rng equal to the current rng and add the current cell in the loops row columns A through J
                End If
                
            End If
                
            
        Next c  'move to next cell in the loop
rng.Select  'select rng
Selection.Delete shift:=xlUp    'delete the rng selected

With AdWB
    .Close True 'close and save the Administrative workbook
End With


End With

To use this code:

1. Close the Administration workbook if it is open
2. Open the Exchangeddirectly workbook
3. Press Alt+F8
4. Clear the macro name field
5. In the macro name field type the text AddToAdmin
6. Select the Create option
7. In between the Sub AddToAdmin() and End Sub copy and paste the above code
8. Anything that appears in green is a comment
9. Don't forget to change the filepath to you Administration workbook's filepath
10. Close out of Visual Basic
11. Press Alt+F8
12. Select the AddToAdmin macro
13. Select the Run option

Let me know if this works for you!

Thanks!

RVASQUEZ

Hi RVASQUEZ,

Thank you so much for looking in to this!
I ran the macro, but stumbled on the following error:

Error 91: Object variable or With blockvariable not set, in line

HTML Code: 

Is it possible for you to alter it, so it will function as it's supposed to?
Kind regards,
Marloes

Hello there,

Try placing

.Activate

above that line of code so that it looks like this

.Activate
rng.select

Hello,
I've been looking at the macro for a while now .
Could it be that variable c is not set?
After running the macro, the only thing that happens is the Administration file is being opened.
The active cells on both files (where the 'cursor' is) do not change.

Thanks,
Marloes

Hey there,

No c is declared as a range and is set to the current cell in the loop. Try just for the moment deleting the following lines and let me know what happens.

rng.Select  'select rng <--- I get the error on this line
Selection.Delete shift:=xlUp    'delete the rng selected

With AdWB
    .Close True 'close and save the Administrative workbook
End With

Hello Rvasquez,

I changed the macro according to your post. Nothing more happened than before.
What did happen is that it ended up activating my Personal macro file (the macro was saved in that file, but i ran it from the Exchanged directly file).
It got me thinking, and I saved the macro in the Exchanged directly file and ran it directly from there. It worked like a charm :-)
Sorry for the trouble...!

I have one more question: if the Administration file doesn't contain a sheet with the correct transporter name, the row gets deleted from the Exchanged directly file but it doesn't get copied to the Administration file. Would it be possible to skip the row in the Exchanged directly file if the transporter name (x) does not exist?

I will go and try the macro on my original file as well.

Thanks so much!

Hello there,

Sorry about that I thought that was understood to place it in the exchangeddirectly worksheet by the line

2.Open the Exchangeddirectly workbook

Glad you could you get that sorted out!

As for this:

I have one more question: if the Administration file doesn't contain a sheet with the correct transporter name, the row gets deleted from the Exchanged directly file but it doesn't get copied to the Administration file. Would it be possible to skip the row in the Exchanged directly file if the transporter name (x) does not exist?

Try the below code, replacing the existing code between the Sub AddToAdmin and End Sub with the below code. What this does is if the worksheet name is not found then it highlights the cell's row black.
Let me know how it works!

Thanks!

'declare variables
Dim c As Range, LR As String, NLR As String
Dim ExWB As Workbook, AdWB As Workbook, x As String
Dim rng As Range, y As Long

Set ExWB = ThisWorkbook 'set exwb equal to the exchange directly workbook
    
    'open the Administration workbook,
    'change the below file path to your file path
    
    Application.Workbooks.Open Filename:="C:\Documents and Settings\rvasquez\My Documents\Example Spreadsheets\Test Folder2\Administration.xls"
        
        'set adWB equal to the Administration workbook
        Set AdWB = ActiveWorkbook
    
With ExWB.Sheets(1) 'with the exchange workbook first worksheet in the workbook
    .Activate   'activate the workbook
    LR = .Range("A6555").End(xlUp).Row  'set the variable LR equal to teh last row that contains a value in column A
        For Each c In .Range("A1:A" & LR + 1).Cells 'loop through cells in column A from row 1 to the last row
            If c.Font.Color = RGB(255, 0, 0) Then   'if the font color in the current cell in the loop is red then

                x = .Range("g" & c.Row).Value   'set x equal to value in the current cell in the loop's row in column G
                .Range("A" & c.Row & ":J" & c.Row).Copy 'copy the cells from A to J of the current cell in the loop's row
                   
                On Error Resume Next
                With AdWB.Sheets(x) 'with the worksheet in the Administrative workbook whose name is equal to x (defined above)
                    
                    If Err.Number = 9 Then  'if the worksheet is not found then
                        c.EntireRow.Interior.Color = RGB(0, 0, 0)   'set the fill color of the row to black
                        y = 1   'set variable y = 1
                    Else
                        NLR = .Range("A6555").End(xlUp).Row + 1 'set NLR equal to the last row in column A the contains a value +1
                        .Range("A" & NLR).PasteSpecial xlPasteValues    'paste the copied values to the first empty cell
                        .Range("A" & NLR & ":J" & NLR).Font.Color = RGB(0, 0, 0)    'turn the font black
                        y = 0   'set variable y = 0
                    End If
                End With
                
                If y = 0 Then   'if y = 0 then
                    If rng Is Nothing Then  'if the variable rng is nothing then
                        Set rng = .Range(.Cells(c.Row, 1), .Cells(c.Row, 10))   'set rng equal to cells A through J of the current row
                    Else: Set rng = Union(rng, .Range(.Cells(c.Row, 1), .Cells(c.Row, 10))) 'if rng does exist then set the rng equal to the current rng and add the current cell in the loops row columns A through J
                    End If
                End If
                
                
                
            End If
                
            
        Next c  'move to next cell in the loop
.Activate
rng.Select  'select rng
Selection.Delete shift:=xlUp    'delete the rng selected

With AdWB
    .Close True 'close and save the Administrative workbook
End With


End With