Announcement

Collapse
No announcement yet.

If a cell meets a condition, copy that row to another worksheet

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • If a cell meets a condition, copy that row to another worksheet



    Hi can someone help please?

    I have two worksheets and wish to copy rows from worksheet 1 to worksheet 2 if a condition is met in one of the cells within that row.

    Hope that makes sense.

    Thanks

  • #2
    Re: If a cell meets a condition, copy that row to another worksheet

    It is likely you have not gotten a reply because your post does not provide enough detail.
    What are the conditions?

    To get the most precise answers, it is best to upload a sample workbook (sensitive data scrubbed/removed) that shows a few manually created examples of the desired results.
    The structure and data types of the workbook must exactly match that of the real workbook. Include in the workbook a clear and explicit explanation of all requirements.The sample workbook only needs to contain enough data to illustrate the need to aid with developing the solution.

    How to edit your post or thread title or upload an attachment

    1. Click the EDIT POST in the gray band immediately below your post
    2. Click Go Advanced
    3. Edit the post or thread title
    4. To upload: scroll down to Manage Attachments -- use ZIP compression if necessary to meet file size limitations
    AAE
    ----------------------------------------------------

    Forum Rules | Message to Cross Posters | How to use Tags

    Comment


    • #3
      Re: If a cell meets a condition, copy that row to another worksheet

      Hoping this explains a little better (attached an example workbook) and someone can help.
      1. Basically worksheet 1 (Details Sheet) gets periodically updated with rows.
      2. A user can then generate a report which is worksheet 2 by clicking the 'Generate Report' button.
      3. When the button is clicked I would like the first column to be searched for either 1, 2, 3, or 4 (a combobox handles this)
      4. When this condition is met, that row then gets copied across to worksheet 2 (Report Sheet)
      5. The whole action starts when the 'Create Report' button is clicked on the userform
      Hope this explains a bit better.

      Many thanks for looking.

      Book1.xls
      Last edited by AAE; August 11th, 2011, 01:09. Reason: delete quote

      Comment


      • #4
        Re: If a cell meets a condition, copy that row to another worksheet

        Hi stickyfeet,

        Paste the following into the code of your UserForm1.

        Instead of copying and pasting each row it stores the data in memory, makes decisions based on your criteria and creates another array that it will paste all at once into your report sheet. This is so that if you happen to have a significant amount of rows it still should run quite zippy.

        Some things to keep in mind here are:
        • This will not copy cell formats to the report.
        • I noticed you had pre-defined formats applied to your report sheet, this code clears that format on those cells that were already written to on the report. This could be fixed either by deleting those rows instead of clearing them (could be slow) or by reapplying the format after the code has run (before unload).
        • I included a function for determining the last row of a worksheet, this isn't really necessary but over the years I've found that determining the last row of a worksheet can be... annoying. This is the function I currently use 99% of the time because as well as determining the last row using the UsedRange property it also deletes empty rows that UsedRange sometimes misinterprets as used.
        • An advanced filter might be something else to look into.
        If I didn't make any sense at all or you have any questions, ask away.

        Cheers,
        MJ

        Code:
        Option Explicit
        Private Sub CommandButton1_Click()
        
        
            Dim lRow As Long, lCol As Long
            Dim lInsertRow As Long
            
            Dim oDetailSheet As Worksheet, oReportSheet As Worksheet
            Dim lLocation As Long
            
            Dim vData As Variant
            Dim vReportData() As Variant
            
            Set oDetailSheet = Sheet1 'Set to the detail sheet
            Set oReportSheet = Sheet2 'Set to the report sheet
        
        
            lLocation = Right(ComboBox1.Value, 1)
            
            If LastRow(oDetailSheet) < 3 Then Unload Me: Exit Sub 'Unload and Exit if there are no rows in data
            
            vData = oDetailSheet.Range(oDetailSheet.Cells(3, 1), oDetailSheet.Cells(3, 1).End(xlDown).End(xlToRight)).Value 'Store relevant data in array (Note: You might want to hardcode the fact that there are 4 columns)
            
            If LastRow(oReportSheet) > 2 Then oReportSheet.Range(oReportSheet.Cells(3, 1), oReportSheet.Cells(3, 1).End(xlDown).End(xlToRight)).Clear 'Clear relevant area in Report sheet
            
            lInsertRow = 0
            For lRow = LBound(vData, 1) To UBound(vData, 1)
                If vData(lRow, 1) = lLocation Then
                
                    lInsertRow = lInsertRow + 1
                    
                    ReDim Preserve vReportData(1 To UBound(vData, 2), 1 To lInsertRow) 'Array is transposed as you can only alter the last dimension of an array while preserving
                    
                    For lCol = LBound(vData, 2) To UBound(vData, 2)
                        vReportData(lCol, lInsertRow) = vData(lRow, lCol)
                    Next lCol
                    
                End If
            Next lRow
            
            TransposeArray2D vReportData
            
            oReportSheet.Range(oReportSheet.Cells(3, 1), oReportSheet.Cells(3, 1)).Resize(UBound(vReportData, 1), UBound(vReportData, 2)).Value = vReportData
            
            Unload Me
        
        
        End Sub
        Private Sub UserForm_Initialize()
        
        
            With ComboBox1
                        .AddItem "Report All Location 1"
                        .AddItem "Report All Location 2"
                        .AddItem "Report All Location 3"
                        .AddItem "Report All Location 4"
            End With
                
        End Sub
        Private Function LastRow(oWS As Worksheet)
            LastRow = oWS.UsedRange.Rows.Count
              Do Until WorksheetFunction.CountA(oWS.Rows(LastRow)) <> 0 Or LastRow = 1
                  oWS.Rows(LastRow).EntireRow.Delete
                  LastRow = oWS.UsedRange.Rows.Count
              Loop
        End Function
        Private Sub TransposeArray2D(ByRef InputArr As Variant)
            Dim lRow As Long, lCol As Long
            Dim vTemp() As Variant
            
            If Not IsArray(InputArr) Then Exit Sub
            
            ReDim vTemp(LBound(InputArr, 2) To UBound(InputArr, 2), LBound(InputArr, 1) To UBound(InputArr, 1))
        
        
            For lRow = LBound(vTemp, 1) To UBound(vTemp, 1)
                For lCol = LBound(vTemp, 2) To UBound(vTemp, 2)
                    vTemp(lRow, lCol) = InputArr(lCol, lRow)
                Next lCol
            Next lRow
            
            InputArr = vTemp
            
        End Sub
        Last edited by LeastAction; August 10th, 2011, 04:21.

        Comment


        • #5
          Re: If a cell meets a condition, copy that row to another worksheet

          Wow! Worked first time thank you very much, its much appreciated.

          Regards

          Comment


          • #6
            Re: If a cell meets a condition, copy that row to another worksheet

            My pleasure,

            Cheers,
            MJ

            Comment


            • #7
              Re: If a cell meets a condition, copy that row to another worksheet

              This code is working perfectly, so much so that I'm trying to apply it to another workbook.

              I'm trying to work through it to try and determine what is going on, but I'm not getting very far.

              So I'm going to be cheeky and ask for a little more help please.

              Rather than looking at the first column, I'm trying to get the code to look at another column. Then do exactly the same thing by copying the whole line.

              I've been looking at 'lLocation' as this is where it gets the value from the combobox, then trying to work out how/where it determines which column to look at.

              Can you help please?

              Thanks

              Comment


              • #8
                Re: If a cell meets a condition, copy that row to another worksheet

                Hi stickyfeet,

                So I've altered the code a bit to make it a little more general and customizable. Firstly to answer your question:

                I've been looking at 'lLocation' as this is where it gets the value from the combobox, then trying to work out how/where it determines which column to look at.
                The code was choosing which column to look at on this line:

                Code:
                If vData(lRow, 1) = vTestValue Then
                The '1' means it's checking against the first column in vData which is the array created from the data range. Also, lLocation was getting its value from the rightmost character of your combobox because of how the values were hardcoded in, this isn't really necessary as you'll see in the updated code.

                So, I changed the code so that it lets you choose which column you would like to filter on and then dynamically updates the combobox with a unique and somewhat sorted (works kind of odd on text) list of values from that column. The subroutines to create the unique list and sort it are at the bottom (some of my favourites).

                I also changed two more things:
                • Instead of clearing the report beforehand I decided to delete the used rows.
                • The way the data values are tested against the filtering value was changed to convert them both to text beforehand, just incase one is converted to text at some other point while being passed to and from the userform.
                So here's a copy of the code to look at but I changed your Userform a bit to allow for my changes so I'll also include the .frm and .frx files so you can just import it into your spreadsheet. If you have any questions, feel free to ask.

                Cheers,
                MJ

                156267.zip

                Code:
                Option Explicit
                Dim lColumn As Long
                Private Sub cmdCreate_Click()
                
                
                    Dim lRow As Long, lCol As Long
                    Dim lInsertRow As Long
                    
                    Dim oDetailSheet As Worksheet, oReportSheet As Worksheet
                    Dim vTestValue As Variant
                    
                    Dim vData As Variant
                    Dim vReportData() As Variant
                    
                    Set oDetailSheet = Sheet1 'Set to the detail sheet
                    Set oReportSheet = Sheet2 'Set to the report sheet
                
                
                    vTestValue = cmbReportType.Value
                    
                    If LastRow(oDetailSheet) < 3 Then Unload Me: Exit Sub 'Unload and Exit if there are no rows in data
                    
                    vData = oDetailSheet.Range(oDetailSheet.Cells(3, 1), oDetailSheet.Cells(3, 1).End(xlDown).End(xlToRight)).Value 'Store relevant data in array (Note: You might want to hardcode the fact that there are 4 columns)
                    
                    If LastRow(oReportSheet) > 2 Then oReportSheet.Range(oReportSheet.Cells(3, 1), oReportSheet.Cells(3, 1).End(xlDown).End(xlToRight)).EntireRow.Delete 'Clear relevant area in Report sheet
                
                
                    lInsertRow = 0
                    For lRow = LBound(vData, 1) To UBound(vData, 1)
                        If CStr(vData(lRow, lColumn)) = CStr(vTestValue) Then
                        
                            lInsertRow = lInsertRow + 1
                            
                            ReDim Preserve vReportData(1 To UBound(vData, 2), 1 To lInsertRow) 'Array is transposed as you can only alter the last dimension of an array while preserving
                            
                            For lCol = LBound(vData, 2) To UBound(vData, 2)
                                vReportData(lCol, lInsertRow) = vData(lRow, lCol)
                            Next lCol
                            
                        End If
                    Next lRow
                    
                    TransposeArray2D vReportData
                    
                    oReportSheet.Range(oReportSheet.Cells(3, 1), oReportSheet.Cells(3, 1)).Resize(UBound(vReportData, 1), UBound(vReportData, 2)).Value = vReportData
                    
                    Unload Me
                
                
                End Sub
                Private Sub UserForm_Initialize()
                    
                    Dim oDetailSheet As Worksheet
                    Dim vColNames() As Variant
                    
                    Set oDetailSheet = Sheet1
                
                
                    vColNames = oDetailSheet.Range(oDetailSheet.Cells(2, 1), oDetailSheet.Cells(2, 1).End(xlToRight)).Value
                    
                    TransposeArray2D vColNames
                    
                    cmbTestCol.List = vColNames
                        
                End Sub
                Private Sub cmbTestCol_Change()
                    
                    Dim oDetailSheet As Worksheet
                    Dim vReportTypes() As Variant
                
                
                    Set oDetailSheet = Sheet1
                    
                    lColumn = cmbTestCol.ListIndex + 1
                    
                    vReportTypes = UniqueItems(oDetailSheet.Range(oDetailSheet.Cells(3, lColumn), oDetailSheet.Cells(2, lColumn).End(xlDown)).Value, True)
                    
                    cmbReportType.List = vReportTypes
                
                
                End Sub
                Private Function LastRow(oWS As Worksheet)
                    LastRow = oWS.UsedRange.Rows.Count
                      Do Until WorksheetFunction.CountA(oWS.Rows(LastRow)) <> 0 Or LastRow = 1
                          oWS.Rows(LastRow).EntireRow.Delete
                          LastRow = oWS.UsedRange.Rows.Count
                      Loop
                End Function
                Private Sub TransposeArray2D(ByRef InputArr As Variant)
                    Dim lRow As Long, lCol As Long
                    Dim vTemp() As Variant
                    
                    If Not IsArray(InputArr) Then Exit Sub
                    
                    ReDim vTemp(LBound(InputArr, 2) To UBound(InputArr, 2), LBound(InputArr, 1) To UBound(InputArr, 1))
                
                
                    For lRow = LBound(vTemp, 1) To UBound(vTemp, 1)
                        For lCol = LBound(vTemp, 2) To UBound(vTemp, 2)
                            vTemp(lRow, lCol) = InputArr(lCol, lRow)
                        Next lCol
                    Next lRow
                    
                    InputArr = vTemp
                    
                End Sub
                Private Function UniqueItems(ByRef ArrayIn, Optional ByVal Sort As Boolean = True) As Variant
                
                
                '   Accepts an array or range as input
                    Dim Unique() As Variant ' array that holds the unique items
                    Dim Element As Variant
                    Dim i As Long
                    Dim FoundMatch As Boolean
                    Dim NumUnique As Long
                '   Loop thru the input array
                    For Each Element In ArrayIn
                        FoundMatch = False
                '       Has item been added yet?
                        For i = 1 To NumUnique
                            If Element = Unique(i) Then
                                FoundMatch = True
                                Exit For '(exit loop)
                            End If
                        Next i
                '       If not in list, add the item to unique list
                        If Not FoundMatch Then
                            NumUnique = NumUnique + 1
                            ReDim Preserve Unique(1 To NumUnique)
                            Unique(NumUnique) = Element
                        End If
                    Next Element
                '   Assign a value to the function
                    If Sort = True Then QuickSort Unique
                    For i = 1 To NumUnique
                    If IsEmpty(Unique(i)) Then Unique(i) = "#Empty#"
                    Next i
                    UniqueItems = Unique
                End Function
                Private Sub QuickSort(ByRef lngArray() As Variant, Optional ByRef swapArray As Variant)
                    Dim iLBound As Long
                    Dim iUBound As Long
                    Dim iTemp As Variant, iTemp2 As Variant
                    Dim iOuter As Long
                    Dim iMax As Long
                    
                    iLBound = LBound(lngArray)
                    iUBound = UBound(lngArray)
                    If Not IsMissing(swapArray) Then If LBound(swapArray) <> iLBound Or UBound(swapArray) <> iUBound Then Err.Raise 9
                    
                    'Dont want to sort array with only 1 value
                    If (iUBound - iLBound) Then
                        
                        'Move the largest value to the rightmost position, otherwise
                        'we need to check that iLeftCur does not exceed the bounds of the
                        'array on EVERY pass (time consuming)
                        iMax = 1
                        For iOuter = iLBound To iUBound
                            If lngArray(iOuter) > lngArray(iMax) Then iMax = iOuter
                        Next iOuter
                        
                        iTemp = lngArray(iMax)
                        If Not IsMissing(swapArray) Then iTemp2 = swapArray(iMax)
                        lngArray(iMax) = lngArray(iUBound)
                        If Not IsMissing(swapArray) Then swapArray(iMax) = swapArray(iUBound)
                        lngArray(iUBound) = iTemp
                        If Not IsMissing(swapArray) Then swapArray(iUBound) = iTemp2
                    
                        'Start quicksorting
                        If Not IsMissing(swapArray) Then
                            InnerQuickSort lngArray, iLBound, iUBound, swapArray
                        Else
                            InnerQuickSort lngArray, iLBound, iUBound
                        End If
                        
                    End If
                End Sub
                
                
                Private Sub InnerQuickSort(ByRef lngArray() As Variant, ByVal iLeftEnd As Long, ByVal iRightEnd As Long, Optional ByRef swapArray As Variant)
                    Dim iLeftCur As Long
                    Dim iRightCur As Long
                    Dim iPivot As Variant, iPivot2 As Variant
                    Dim iTemp As Variant, iTemp2 As Variant
                    
                    If iLeftEnd >= iRightEnd Then Exit Sub
                    
                    iLeftCur = iLeftEnd
                    iRightCur = iRightEnd + 1
                    iPivot = lngArray(iLeftEnd)
                    If Not IsMissing(swapArray) Then iPivot2 = swapArray(iLeftEnd)
                    
                    'Arrange values so that < pivot are on the left and > pivot are on the right
                    Do
                        'Find >= value on left side
                        Do
                            iLeftCur = iLeftCur + 1
                        Loop While lngArray(iLeftCur) < iPivot
                        
                        'Find <= value on right side
                        Do
                            iRightCur = iRightCur - 1
                        Loop While lngArray(iRightCur) > iPivot
                        
                        'No more swapping to do
                        If iLeftCur >= iRightCur Then Exit Do
                        
                        'Swap
                        iTemp = lngArray(iLeftCur)
                        If Not IsMissing(swapArray) Then iTemp2 = swapArray(iLeftCur)
                        lngArray(iLeftCur) = lngArray(iRightCur)
                        If Not IsMissing(swapArray) Then swapArray(iLeftCur) = swapArray(iRightCur)
                        lngArray(iRightCur) = iTemp
                        If Not IsMissing(swapArray) Then swapArray(iRightCur) = iTemp2
                    Loop
                    
                    'Call quicksort recursively on left and right subarrays
                    lngArray(iLeftEnd) = lngArray(iRightCur)
                    If Not IsMissing(swapArray) Then swapArray(iLeftEnd) = swapArray(iRightCur)
                    lngArray(iRightCur) = iPivot
                    If Not IsMissing(swapArray) Then swapArray(iRightCur) = iPivot2
                    
                    If Not IsMissing(swapArray) Then
                        InnerQuickSort lngArray, iLeftEnd, iRightCur - 1, swapArray
                        InnerQuickSort lngArray, iRightCur + 1, iRightEnd, swapArray
                    Else
                        InnerQuickSort lngArray, iLeftEnd, iRightCur - 1
                        InnerQuickSort lngArray, iRightCur + 1, iRightEnd
                    End If
                End Sub

                Comment


                • #9
                  Re: If a cell meets a condition, copy that row to another worksheet

                  Hi and thanks again. Works perfectly! Also been spending a bit of time going through the code and trying to work out what's going on.

                  I've reused the code several times in different workbooks/projects. So once again a big thanks for your time.

                  Regards

                  :-)

                  Comment


                  • #10
                    Re: If a cell meets a condition, copy that row to another worksheet

                    It's my pleasure, I'm glad you're finding it useful and learning from it. If you have any questions as you go through the code, feel free to ask.

                    Cheers,
                    MJ

                    Comment


                    • #11
                      Re: If a cell meets a condition, copy that row to another worksheet

                      Hi, hoping LeastAction is around.

                      I'm trying to do something similar to the above by reusing your code. I'm stuggling with it so was hoping you can help again.

                      Same kind of worksheet but there is a number in Column 'S' and when that number is met (users selects) then I need that row copied across to a new worksheet.

                      I kind of (well I think) I understand bits of the code but getting it to look in 'S' just doesnt seem to work.

                      Big thanks!

                      Comment


                      • #12
                        Re: If a cell meets a condition, copy that row to another worksheet

                        how to do the same thing with using user form in excel. i dont want to use combo box.

                        Comment


                        • #13


                          Re: If a cell meets a condition, copy that row to another worksheet

                          Please do not post questions in threads started by other members.

                          If you have a query then start your own thread, give it an accurate and concise title that summarises your problem and explain your issue fully.

                          If your question relates to this (or any other) thread, then include a link by copying the URL from the address bar of your browser and pasting into your message.

                          Make sure you explain exactly the changes needed and how you would see them working. The code in this thread relates to selections from a combobox but you "dont want to use combo box" - please explain the process you have in mind.

                          Comment

                          Working...
                          X