VBA to copy entire row If Column J = TRUE

[Bvendett4]

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.

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.

 

[vcoolio]

I think its best if I have a look at your actual workbook so please upload a sample (with just the two sheets in question) to a free file sharing site such as Drop Box then post the link to your file back here.

Please use dummy data.

Cheerio,
vcoolio.

 

[Bvendett4]

Hello,
Okay, so I am a bit conscious of uploading this workbook as requested - only on the basis that if I clear all contents for the cells there would be nothing to see (i.e. all the filters would cleared that I need intact) but if I dont clear all the contents there is third party information available on the workbook, There is around 170000 live cells currently on the workbook.
I understand it is easier to see it visually to understand its logic, are you just looking to see the macro codes that are already installed or do you require an overview of the whole worksheet?
Looking in depth these filters are just text filters that have been added and then saved as the workbook and not actual macros as I first anticipated.

Just a little overview - Ive recently taken on a new role as an expediter at my company, the gentleman who created this workbook is currently on holiday for four months - so I am trying to install these features myself.

Many Thanks

 

[Rick Rothstein]

Here is a macro that does not use AutoFilter so it should not affect any settings you have for it, does it do what you want?

[table="width: 500"]
[tr]
	[td]Sub Test()
  Dim TableAddress As String
  TableAddress = Sheets("OrderStatus").ListObjects("Table_SRV04_SWANSync_qryProductionPlanner").Range.Address
  Sheets("OrderStatus").ListObjects("Table_SRV04_SWANSync_qryProductionPlanner").Unlist
  Sheets("OrderStatus").Columns("J").SpecialCells(xlFormulas, xlLogical).EntireRow.Copy
  Sheets("[B][COLOR="#FF0000"]Test[/COLOR][/B]").Range("A1").PasteSpecial
  Sheets("OrderStatus").ListObjects.Add(xlSrcRange, Range(TableAddress), , xlYes).Name = "Table_SRV04_SWANSync_qryProductionPlanner"
  Application.CutCopyMode = False
End Sub[/td]
[/tr]
[/table]

 

[Bvendett4]

Good Morning Rick,
This runs a very similar action to the code that Vcoolio has provided, unfortunately this removes headers that I would like on the "Test" sheet and still clears all the text filters from the "OrderStatus" Sheet that have been applied and then saved as.
Apologies, as I feel Im being picky and I appreciate all the help you are providing.
Many Thanks

 

[vcoolio]

Hello Bvendett4,

Looking at Rick's code, there is no apparent reason why its behaving as you describe which would suggest that something else is at play. This is why we would need to have a look at your workbook.

You can create a copy of your workbook, delete all sheets except the two in question and if these two sheets have sensitive data then simply change it to dummy data. Upload the copy as described in post #11 .

Cheerio,
vcoolio.

 

[natasha_9]

hello friends,
i am new to vb and i needed help. basically i have drop down list of value and i want to set the condition that if my value in the cell is "others, specify", it should automatically go to the next cell below for wriring the value. i tried but my range is from A19 to E19 , i want to set a common criteria for all.

 

[Rick Rothstein]

Good Morning Rick,
This runs a very similar action to the code that Vcoolio has provided, unfortunately this removes headers that I would like on the "Test" sheet and still clears all the text filters from the "OrderStatus" Sheet that have been applied and then saved as.

Give this macro a try instead then...

[table="width: 500"]
[tr]
	[td]Sub Test()
  With Sheets("[B][COLOR="#FF0000"]Test[/COLOR][/B]")
    .UsedRange.Clear
    Range("Table_SRV04_SWANSync_qryProductionPlanner[#All]").Copy .Range("A1")
    .ListObjects(1).Unlist
    .Columns("J").SpecialCells(xlFormulas, xlTextValues).EntireRow.Delete
  End With
End Sub[/td]
[/tr]
[/table]

Note to vcoolio: I think the reason the OP sees the same problem has to do with the Table Unlist command. The above code does all its work on a copy of the table which avoids the problems (which, in turn, reduces the number of lines of code needed).

 

[vcoolio]

Hello Natasha_9,

Please do not hijack other people's threads. Please start your own thread and fully explain your issue there.

Cheerio,
vcoolio.

 

[Bvendett4]

Hi Rick,
It feels like we are almost there! This copies everything in visual from "OrderStatus" sheet not just the the items that are highlighted "TRUE" in Column J of "OrderStatus" sheet.
This also finishes with a runtime error 9 - subscript out of range. The debug mode highlights this line of code in red.

Sub Test()
  With Sheets("Test")
    .UsedRange.Clear
    Range("Table_SRV04_SWANSync_qryProductionPlanner[#All]").Copy .Range("A1")
[COLOR=#ff0000]    .ListObjects(1).Unlist[/COLOR]
    .Columns("J").SpecialCells(xlFormulas, xlTextValues).EntireRow.Delete
  End With
End Sub

However this does clear up the un-filtering issues as requested.

 

[Rick Rothstein]

Hi Rick,
It feels like we are almost there! This copies everything in visual from "OrderStatus" sheet not just the the items that are highlighted "TRUE" in Column J of "OrderStatus" sheet.
This also finishes with a runtime error 9 - subscript out of range. The debug mode highlights this line of code in red.

Sub Test()
  With Sheets("Test")
    .UsedRange.Clear
    Range("Table_SRV04_SWANSync_qryProductionPlanner[#All]").Copy .Range("A1")
[COLOR=#ff0000]    .ListObjects(1).Unlist[/COLOR]
    .Columns("J").SpecialCells(xlFormulas, xlTextValues).EntireRow.Delete
  End With
End Sub

I cannot duplicate what you are reporting. I am not sure what to tell you as the code I posted runs without error here. The clearing of the UsedRange on the "Test" sheet should make the table that is copied to it afterwards the first ListObject on the sheet.

Edit Note: Just checking, but you do still have a real Excel Table object on your OrderStatus sheet and that table is named "Table_SRV04_SWANSync_qryProductionPlanner", correct?