VBA to copy entire row If Column J = TRUE

Bvendett4

New Member
Joined
Apr 10, 2018
Messages
24
Good Morning,
I currently use a workbook that holds our whole works orders database amongst many other things.
However predominantly I use Sheet9 named OrderStatus.
In Column J I have a formula that reads if =IF([@[Revised DueDate]=]=>[@DueDate],TRUE,"").
So column J has around 138 rows but will continue to grow or diminish dependent on parts arriving and the amendment of the revised due date which is changed on an in-house planning tool.

What I want is for if this formula does =TRUE a VBA code to copy the entire Row into sheet 5 named Test, I would like the same lines to be overwritten if there is an amendment and not duplicated.
I have been shopping about trying to complete this myself using variable modified codes similar to the below but just cant get these to work and I cannot see the where my issue lies. Th code runs with no issues however there is nothing copied into Test Sheet. I have also tried using the Sheet5 name instead of Test sheet but no luck.

Code:
Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("OrderStatus").UsedRange.Rows.Count
    J = Worksheets("Test").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Test").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("OrderStatus").Range("J1:J" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "TRUE" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Test").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Any tips or help would be massivley appreciated.
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Hello Bvendett4,

You could try filtering Column J for TRUE as follows:-


Code:
Sub Test()

Dim ws As Worksheet: Set ws = Sheets("Order Status")
Dim sh As Worksheet: Set sh = Sheets("Test")

Application.ScreenUpdating = False

sh.UsedRange.Offset(1).Clear

With ws.[A1].CurrentRegion
       .AutoFilter 10, True
       .Offset(1).EntireRow.Copy
       sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
       .AutoFilter
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


I hope that this helps,

Cheerio,
vcoolio.
 
Upvote 0
Hi Vcoolio,
This is perfect.
Thanks for the assistance on this, this seems a much simpler solution.

I have just noticed however that this resets and removes the filters that where present on the original worksheet - is there a way to avoid this?

What I failed to mention previously was the workbook its copying from is formatted as a table and there are varied formulas in some cells, would there be a way to copy these as well?
Or would this be simpler to just format the new worksheet to what the worksheet is copied from - my only intention is to create another sheet using the same code as above highlighting where the revised due date is less than the due date therefore identifying orders we have brought forward.

Many Thanks
 
Last edited:
Upvote 0
Hello Bvendett4,


You could change this line:-

Code:
sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues

to

Code:
sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll

This will bring everything over (values, formulae, formatting etc)

Cheerio,
vcoolio.
 
Upvote 0
Hi Vcoolio,
This has copied all the formulas and conditional formatting which is my primary need, it still hasn't copied over the actual table formatted colour, but that shouldn't be too much of an issue as I will format manually.

As in my previous amendment however, it is removing all the filters on the original worksheet we are copying from, i.e. we hide all invoiced orders and certain orders and documentation.
Is there a way to ensure all the filters remain in place on the original worksheet?

Again, I appreciate the help on this.
 
Upvote 0
Hello Bvendett4,
it still hasn't copied over the actual table formatted colour, but that shouldn't be too much of an issue as I will format manually.

I should be able to come up with a work-around for you. What columns are covered by the table (e.g. A:J)?
Is there a way to ensure all the filters remain in place on the original worksheet?

That would be the "Order Status" sheet.

Add the following line of code:-

Code:
ws.[A1].AutoFilter

directly after this line of code:-

Code:
End With

Cheerio,
vcoolio.

P.S. BTW. What is the table name?
 
Last edited:
Upvote 0
Yeah, that workaround would be great if possible.
Just a quick clarification that it is order "OrderStatus" Sheet there is no space.

I've highlighted the table and the table name appears as Table_SRV04_SWANSync_qryProductionPlanner. The table ranges from A1 (row 1 being a header for each column) to Column BC19509, although the amount overdue will not match the amount of cells in the "OrderStatus" sheet.

Many Thanks
 
Upvote 0
Hello vcoolio,
The above code change is still eliminating all the filters on the "OrderStatus" page, would this be because there is macros that are doing these auto filters?
There is no coding in the actual "OrderStatus" sheet but there are 6 modules that are attached to the workbook.
I cannot see any of the modules that directly affect "OrderStatus"page however.

My apologies if this new information throws anything out of array.
 
Upvote 0
Hello Bvendett4,

Try the code amended as follows:

Code:
Sub Test()

Dim ws As Worksheet: Set ws = Sheets("OrderStatus")
Dim sh As Worksheet: Set sh = Sheets("Test")
Dim lr As Long
lr = ws.Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

ws.ListObjects("Table_SRV04_SWANSync_qryProductionPlanner").Unlist
sh.UsedRange.Clear

With ws.[A1].CurrentRegion
       .AutoFilter 10, True
       .EntireRow.Copy
       sh.Range("A" & Rows.Count).End(3).PasteSpecial xlPasteAll
       .AutoFilter
End With

ws.ListObjects.Add(xlSrcRange, Range("A1:BC" & lr), , xlYes).Name = "Table_SRV04_SWANSync_qryProductionPlanner"

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

This time it will take the headings across to the Test sheet also so you can start with a blank sheet if you like.

Please note that the table formatting colours will be copied across also but they will not be in sequence (e.g. Blue/White/Blue/White) as it is dependent on which row the "TRUE" value is placed. You may have, say, three "TRUE" values in blue coloured rows and only one "TRUE" value in a white coloured row.

I hope that this helps.

Cheerio,
vcoolio.
 
Upvote 0
Hi Vcoolio,
This seems to do everything I want to in terms of bringing the format and information across to the new sheet. So thank you very much for the assistance on this.
I am still however having issues with the auto filter being eliminated from the "OrderStatus" sheet, so I have looking around the internet trying to find some information.
So far I have found the below code for clearing the auto filter and then reapplying it - however when I try to run it there is a Runtime error 91 object variable which I cant fathom out.
Your code is incorporated into the middle of this - but essentially I want the auto filter to clear on the "OrderStatus" sheet and then be reapplied - if you could help me on this "hopefully" last thing, again, it would be much appreciated.

Code:
Sub ReDoAutoFilter()


Dim w As Worksheet
Dim filterArray() As Variant
Dim currentFiltRange As Variant
Dim col As Integer


Set w = ActiveSheet


currentFiltRange = w.AutoFilter.Range.Address


' Captures AutoFilter settings
With w.AutoFilter


With .Filters


ReDim filterArray(1 To .Count, 1 To 3)
For f = 1 To .Count
With .Item(f)
If .On Then
If IsArray(.Criteria1) Then
filterArray(f, 1) = .Criteria1
CriteriaOne = "=Array(" & Replace(Replace(Join(.Criteria1, ","), "=", Chr(34)), ",", Chr(34) & ",") & Chr(34) & ")"
Debug.Print "CriteriaOne's Field " & f & " is an Array consisting of:"
Debug.Print "  " & CriteriaOne


filterArray(f, 2) = .Operator
Debug.Print "Field:" & f & "'s .Operator value is: " & .Operator
Debug.Print "  " & " (7 =xlFilterValues)"


ElseIf Not IsArray(.Criteria1) Then filterArray(f, 1) = .Criteria1
Debug.Print "Field:" & f & "'s .Criteria1 is: " & .Criteria1


If .Operator Then
                                       '2nd Dimension, 2nd column/index
filterArray(f, 2) = .Operator
Debug.Print "Field:" & f & "'s .Operator is: " & .Operator
Debug.Print "  " & " (2=xlOr, 1=xlAnd)"


'2nd Dimension, 3rd column/index
Debug.Print "Field:" & f & "'s .Criteria2 is: " & .Criteria2


End If
End If
End If
End With
Next f
End With
End With


Dim ws As Worksheet: Set ws = Sheets("OrderStatus")
Dim sh As Worksheet: Set sh = Sheets("Test")
Dim lr As Long
lr = ws.Range("A" & Rows.Count).End(xlUp).Row


Application.ScreenUpdating = False


ws.ListObjects("Table_SRV04_SWANSync_qryProductionPlanner").Unlist
sh.UsedRange.Clear


With ws.[A1].CurrentRegion
.AutoFilter 10, True
.EntireRow.Copy
sh.Range("A" & Rows.Count).End(3).PasteSpecial xlPasteAll
.AutoFilter
End With


ws.ListObjects.Add(xlSrcRange, Range("A1:BC" & lr), , xlYes).Name = "Table_SRV04_SWANSync_qryProductionPlanner"


Application.CutCopyMode = False
Application.ScreenUpdating = True
ws.[A1].AutoFilter


' Restores Filter settings
For f = 1 To UBound(filterArray(), 1)
If Not IsEmpty(filterArray(f, 1)) Then
If filterArray(f, 2) Then
w.Range(currentFiltRange).AutoFilter Field:=f, _
Criteria1:=filterArray(f, 1), _
Operator:=filterArray(f, 2), _
Criteria2:=filterArray(f, 3)


Else
w.Range(currentFiltRange).AutoFilter Field:=f, _
Criteria1:=filterArray(f, 1)
End If
End If
Next f
End Sub
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,722
Members
448,294
Latest member
jmjmjmjmjmjm

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top