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

stickyfeet · Jul 20th 2011

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

AAE · Jul 23rd 2011

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.

[COLOR="navy"]How to edit your post or thread title or upload an attachment[/COLOR]

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

stickyfeet · Aug 9th 2011

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.

Basically worksheet 1 (Details Sheet) gets periodically updated with rows.
A user can then generate a report which is worksheet 2 by clicking the 'Generate Report' button.
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)
When this condition is met, that row then gets copied across to worksheet 2 (Report Sheet)
The whole action starts when the 'Create Report' button is clicked on the userform

Hope this explains a bit better.

Many thanks for looking.

[ATTACH=CONFIG]40299[/ATTACH]

LeastAction · Aug 9th 2011

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

Display More

stickyfeet · Aug 9th 2011

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

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

Regards

LeastAction · Aug 9th 2011

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

My pleasure,

Cheers,
MJ

stickyfeet · Aug 10th 2011

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

LeastAction · Aug 10th 2011

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:

Quote

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

[ATTACH=CONFIG]40333[/ATTACH]

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

Display More

stickyfeet · Aug 12th 2011

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

LeastAction · Aug 12th 2011

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

stickyfeet · Sep 5th 2011

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!

Pradeepkatariya · Sep 30th 2016

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.

cytop · Sep 30th 2016

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.

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

Participate now!

Share