Results 1 to 14 of 14
  1. #1
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts

    Copy Values > 0 based on certain criteria

    I have a sheet “Data” where I want to copy data from A19 to the last row containing data in Col I where the values are > 0 in Col H and where ??? appears in Col I. This must be copied to the last row in Col A on sheet “Recon items” after the last containing data. I Also want a heading on sheet "Recon Items" to be inserted before the data is copied called "Items not on Stock Report"

    For eg if H19 contains 0 and I19 contains ??? then that row is not to be copied. If for eg. H20 contains 12584.07 and I20 contains ??? , then this data to be copied to sheet “Recon Items” in Col A

    I have tried to right code to copy the data based on the above criteria, but cannot get it to work. I have manually copied the data to show what the final result must look like

    It would be appreciated if someone could kindly assist me
    Attached Files Attached Files
    Last edited by HowardC; 2016-10-06 at 22:22.

  2. #2
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Hi Howard,

    Place the following code in the Recon Items' worksheet module. Each time the sheet is accessed, it will provide an updated list.

    HTH,
    Maud

    Code:
    Private Sub Worksheet_Activate()
        Application.ScreenUpdating = False
    '--------------------------------------
    'DECLARE AND SET VARIABLES
        Dim ws1 As Worksheet, cell As Range, rng As Range
        Dim Lastrow As Long, NextRow As Long
        Set ws1 = Worksheets("Data")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("H19:H" & Lastrow)
    '--------------------------------------
    'CLEAR RECON ITEMS SHEET BUT LEAVE HEADER
        On Error Resume Next
        UsedRange.Offset(1, 0).Resize(UsedRange.Rows.Count - 1, UsedRange.Columns.Count).ClearContents
    '--------------------------------------
    'TEST CRITERIA AND MOVE DATA
        For Each cell In rng
            If cell > 0 And cell.Offset(0, 1) = "???" Then
                NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
                If NextRow = 1 Then NextRow = 2
                For I = 1 To 9
                    Cells(NextRow, I) = cell.Offset(0, I - 8)
                Next I
            End If
        Next cell
    '--------------------------------------
    'CLEANUP
        On Error GoTo 0
        Set ws1 = Nothing
        Set cell = Nothing
        Set rng = Nothing
        Application.ScreenUpdating = True
    End Sub

  3. #3
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Thanks Maud

    It works perfectly on the sample data uploaded.

    I have another workbook, where the only difference is that the column numbers are different but I cannot get the data to extract correctly

    Kindly amend the code
    Attached Files Attached Files

  4. #4
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    I have resolved the problem. I have shown the changes in red

    Code:
     Private Sub Worksheet_Activate()
        Application.ScreenUpdating = False
    '--------------------------------------
    'DECLARE AND SET VARIABLES
        Dim ws1 As Worksheet, cell As Range, rng As Range
        Dim Lastrow As Long, NextRow As Long
        Set ws1 = Worksheets("Data")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("M19:M" & Lastrow)
    '--------------------------------------
    'CLEAR RECON ITEMS SHEET BUT LEAVE HEADER
        On Error Resume Next
        UsedRange.Offset(1, 0).Resize(UsedRange.Rows.Count - 1, UsedRange.Columns.Count).ClearContents
    '--------------------------------------
    'TEST CRITERIA AND MOVE DATA
        For Each cell In rng
            If cell > 0 And cell.Offset(0, 1) = "???" Then
                NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
                If NextRow = 1 Then NextRow = 2
                For I = 1 To 14
                    Cells(NextRow, I) = cell.Offset(0, I - 13)
                Next I
            End If
        Next cell
    '--------------------------------------
    'CLEANUP
        On Error GoTo 0
        Set ws1 = Nothing
        Set cell = Nothing
        Set rng = Nothing
        Application.ScreenUpdating = True
    End Sub

  5. The Following User Says Thank You to HowardC For This Useful Post:

    Maudibe (2016-10-10)

  6. #5
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    If the data needs to be copied from two sheets ("data1" & "Data2") based on the criteria in Post #1 to "Recon Items" how do I amend the code?

    I have tried to amend the code, but cannot get it to work. I also want the first thirteen rows on sheet "Recon Items" not to cleared and the data to be pasted from Row A15 on sheet "Recon Items"



    Code:
     Set ws1 = Worksheets = Array("Data1", "Data2")
    Attached Files Attached Files
    Last edited by HowardC; 2016-10-10 at 00:18.

  7. #6
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Howard,

    I would recode it like this:

    econ sheet module:
    Code:
    Private Sub Worksheet_Activate()
        Application.ScreenUpdating = False
    '--------------------------------------
    'DECLARE AND SET VARIABLES
        Dim ws1 As Worksheet, rng As Range
        Dim Lastrow As Long, NextRow As Long
    '--------------------------------------
    'CLEAR RECON ITEMS SHEET BUT LEAVE HEADER
        On Error Resume Next
        UsedRange.Offset(1, 0).Resize(UsedRange.Rows.Count - 1, UsedRange.Columns.Count).ClearContents
        On Error GoTo 0
    '--------------------------------------
    'MOVE DATA1
        Set ws1 = Worksheets("Data1")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("M19:M" & Lastrow)
        MoveData rng
    '--------------------------------------
    'MOVE DATA2
        Set ws1 = Worksheets("Data2")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("M2:M" & Lastrow)
        MoveData rng
    '--------------------------------------
    'CLEANUP
        Set ws1 = Nothing
        Set rng = Nothing
        Application.ScreenUpdating = True
    End Sub
    In a standard module:
    Code:
    Public Sub MoveData(r As Range)
    '--------------------------------------
    'TEST CRITERIA AND MOVE DATA
        For Each cell In r
            If cell > 0 And cell.Offset(0, 1) = "???" Then
                NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
                If NextRow = 1 Then NextRow = 2
                For I = 1 To 14
                    Cells(NextRow, I) = cell.Offset(0, I - 13)
                Next I
            End If
        Next cell
    End Sub

  8. #7
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    Thanks for the help. The data copies the correct info to sheet "Recon Items", except that I need the data to be pasted after row 14 on sheet "Recon Items"

    Kindly amend your code

  9. #8
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    I have a similar workbook to the one posted in Post # 5.

    I have values in Col F and data in Col E from row 19 onwards

    Where the data in Col E does NOT contain "NO" and the value in Col F > 0 then all the data from Col A to F pertaining to the above criteria to be copied to sheet "Recon Items"

    I have tried to amend your code, but it extracts the data containing "NO" as well


    Kindly check & amend my code
    Attached Files Attached Files
    Last edited by HowardC; 2016-10-10 at 14:08.

  10. #9
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    I need the data to be pasted after row 14 on sheet "Recon Items"

    Howard,

    The following revision will move the lines from the data sheets to the Recon sheet starting on row 15 (post #7)

    Code:
    Private Sub Worksheet_Activate()
        Application.ScreenUpdating = False
    '--------------------------------------
    'DECLARE AND SET VARIABLES
        Dim ws1 As Worksheet, rng As Range
        Dim Lastrow As Long, NextRow As Long
    '--------------------------------------
    'CLEAR RECON ITEMS SHEET BUT LEAVE HEADER
        Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        If Lastrow = 13 Then Lastrow = 14
        Range("A14:N" & Lastrow).ClearContents
    '--------------------------------------
    'MOVE DATA1
        Set ws1 = Worksheets("Data1")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("M19:M" & Lastrow)
        MoveData rng
    '--------------------------------------
    'MOVE DATA2
        Set ws1 = Worksheets("Data2")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("M2:M" & Lastrow)
        MoveData rng
    '--------------------------------------
    'CLEANUP
        Set ws1 = Nothing
        Set rng = Nothing
        Application.ScreenUpdating = True
    End Sub
    In a standard module:
    Code:
    Public Sub MoveData(r As Range)
    '--------------------------------------
    'TEST CRITERIA AND MOVE DATA
        For Each cell In r
            If cell > 0 And cell.Offset(0, 1) = "???" Then
                NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                If NextRow < 15 Then NextRow = 15
                For I = 1 To 14
                    Cells(NextRow, I) = cell.Offset(0, I - 13)
                Next I
            End If
        Next cell
    End Sub

  11. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2016-10-11)

  12. #10
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    I have a similar workbook to the one posted in Post # 5.
    I have values in Col F and data in Col E from row 19 onwards
    Where the data in Col E does NOT contain "NO" and the value in Col F > 0 then all the data from Col A to F pertaining to the above criteria to be copied to sheet "Recon Items"
    I have tried to amend your code, but it extracts the data containing "NO" as well
    Howard,

    The following code is a solution to your post #8

    In the worksheet module:
    Code:
    Private Sub Worksheet_Activate()
        Application.ScreenUpdating = False
    '--------------------------------------
    'DECLARE AND SET VARIABLES
        Dim ws1 As Worksheet, rng As Range
        Dim Lastrow As Long, NextRow As Long
    '--------------------------------------
    'CLEAR RECON ITEMS SHEET BUT LEAVE HEADER
        Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        If Lastrow = 13 Then Lastrow = 14
        Range("A14:F" & Lastrow).ClearContents
    '--------------------------------------
    'MOVE DATA1
        Set ws1 = Worksheets("Data1")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("E19:E" & Lastrow)
        MoveData rng
    '--------------------------------------
    'MOVE DATA2
        Set ws1 = Worksheets("Data2")
        Lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
        Set rng = ws1.Range("E19:E" & Lastrow)
        MoveData rng
    '--------------------------------------
    'CLEANUP
        Set ws1 = Nothing
        Set rng = Nothing
        Application.ScreenUpdating = True
    End Sub
    In a standard module:
    Code:
    Public Sub MoveData(r As Range)
    '--------------------------------------
    'TEST CRITERIA AND MOVE DATA
        For Each cell In r
            If UCase(cell) <> "NO" And cell.Offset(0, 1) > 0 Then
                NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                If NextRow < 15 Then NextRow = 15
                For I = 1 To 6
                    Cells(NextRow, I) = cell.Offset(0, I - 5)
                Next I
            End If
        Next cell
    End Sub

  13. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2016-10-10)

  14. #11
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Thanks Maud. The Code Works perfectly. The Dates need to be copied in the same format as on sheets Data1 & Data2 (format dd/mm/yyyy)

    Kindly amend your code to incorporate this

  15. #12
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Code works perfectly. Thanks for all your help

  16. #13
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Howard,

    The dates should be formatted by formatting the columns on the sheet, not by code.

    HTH,
    Maud

  17. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2016-10-11)

  18. #14
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Thanks Maud. I have formatted the dates on the sheet and it works perfectly

Posting Permissions

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