Error Checking in Excel
Page 1 of 3 123 LastLast
Results 1 to 10 of 21

Thread: VBA to copy entire row If Column J = TRUE

  1. #1
    New Member
    Join Date
    Apr 2018
    Posts
    21
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default VBA to copy entire row If Column J = TRUE

    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.

  2. #2
    Board Regular
    Join Date
    Jun 2014
    Posts
    651
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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.

  3. #3
    New Member
    Join Date
    Apr 2018
    Posts
    21
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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 by Bvendett4; Aug 23rd, 2018 at 07:03 AM. Reason: Additional Requirement

  4. #4
    Board Regular
    Join Date
    Jun 2014
    Posts
    651
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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.

  5. #5
    New Member
    Join Date
    Apr 2018
    Posts
    21
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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.

  6. #6
    Board Regular
    Join Date
    Jun 2014
    Posts
    651
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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 by vcoolio; Aug 23rd, 2018 at 08:58 AM. Reason: Add P.S.

  7. #7
    New Member
    Join Date
    Apr 2018
    Posts
    21
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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

  8. #8
    New Member
    Join Date
    Apr 2018
    Posts
    21
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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.

  9. #9
    Board Regular
    Join Date
    Jun 2014
    Posts
    651
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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.

  10. #10
    New Member
    Join Date
    Apr 2018
    Posts
    21
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to copy entire row If Column J = TRUE

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •