VBA Copy row if row contains info from dropdown

[dyl_jones]

Hello all,
I have a problem ive been trying to overcome in work.

I have a database of job cards with doc numbers dates and all sorts.

Ive created a report sheet that picks certain information using lookups and index serches. I pick a name from a dropdown box which then copies all instances of that name. This takes about 2 mins due to the database having nearly 3000 entries.

Is it possible to do this using VBA? Copy all rows containing the employees name to sheet 3? My formulas pick out the rest when its in page 3.

Ive been racking my brains for 3 weeks now! Help!

Thanks

Dylan

 

[Ralajer]

Dylan, welcome to the board.

Yes, VBA could copy all the rows that match given criteria to another sheet. To clarify when you wrote database do mean data stored in the workbook or a connection to an external database.

Just provide details about the layout of data.

 

[dyl_jones]

Thank you for the reply.

Yes, the data is stored in the same workbook.

I'd love to learn basic vba so maybe some pointers in the right direction?

 

[Ralajer]

The below is some working code that does about what you want. Review it and make changes to match your situation. Let me know if you have any questions about how it works.

Sub copyRows()

    Dim wsData As Worksheet
    Dim wsReport As Worksheet
    Dim srcRng As Range
    Dim cell As Range
    Dim criteriaVal As String
    Dim OutputRow As Long
    
    Set wsData = Sheets("Database")
    Set wsReport = Sheets("Report")
    
    '// Start row on report sheet to receive data
    OutputRow = 3
    
    '// Clear Report Sheet
    wsReport.Rows(OutputRow & ":5000").ClearContents
    
    '// Value that is to be looked up
    criteriaVal = wsReport.Range("A2").Value
    
    '// Specify first row and column of database name field
    Set srcRng = wsData.Range("A2")
    
    '// Returns range from Start to last row in column
    Set srcRng = wsData.Range(srcRng, _
                        wsData.Cells(Rows.Count, srcRng.Column).End(xlUp))

    '// Loop Through database name column
    For Each cell In srcRng
        '// if the value in the loop cell is equal to the dropdown name
        If cell.Value = criteriaVal Then
            '// Copy the entire row output to next available row
            cell.EntireRow.Copy wsReport.Cells(OutputRow, 1)
            OutputRow = OutputRow + 1
        End If
    Next cell
End Sub

 

[dyl_jones]

Wow, That did exactly what I needed. Where can I find out what each command is doing? eg Search the terms, used.

I attached the macro to a button, but takes about 5 mins or more to run the query. Any way to speed it up?

 

[Ralajer]

Try adding this to very beginning right after the Dim Statement

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

Then this right at the end before the End Sub

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With

The first block turns off automatic calculation, screening updating and events. The second turns those back on. Which can shave a lot off the total time. If the the above doesn't cut down the run time enough let me know.

 

[dyl_jones]

Thank you very much for the reply.

The sheet now runs the query in around 10 seconds.

I'm sure I can deal with that! Such an easy to understand code.

Excellent programmer.

How long would it take to learn VBA to an intermediate level? Probably a question that gets asked all the time. I guess its a case of try and play!

Thank you again.

 

[Ralajer]

Good to hear it cut down the time but the 10 seconds could probably be reduced. Since you last post I though of how to increase the performance and will get to it when I have time.

How long it takes really depends on your background and how much time you are willing to spend learning. So 6 month to 6 Years.

I would recommend to someone who has an interested in learning how to program to watch Programming Methodology, by Stanford University on YouTube.

It's the recorded lectures of an introductory programming course. While it is in the Java programming language it's intend to teach programming concepts rather than syntax. Most of the concepts carry over to VBA.

 

[Ralajer]

I had time now. The below should be faster it doesn't look at each row but searches through the range with the Find and Findnext methods. Its run time is more dependent on the number of matches and not on the total number of records. Most of tests seemed under a second.

Sub copyRows()

    Dim wsData As Worksheet
    Dim wsReport As Worksheet
    
    Dim srcRng As Range
    Dim srcAfter As Range
    Dim foundRng As Range
    Dim copyRng As Range
    
    Dim criteriaVal As String
    Dim OutputRow As Long
    Dim LR As Long
    Dim firstFound As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set wsData = Sheets("Database")
    Set wsReport = Sheets("Report")
    
    '// Start row on report sheet to receive data
    OutputRow = 3
    
    '// Clear Report Sheet
    LR = wsReport.Cells(Rows.Count, 1).End(xlUp).Row    '// Last row
    wsReport.Rows(OutputRow & ":" & LR).ClearContents
    
    '// Value that is to be looked up
    criteriaVal = wsReport.Range("A2").Value
    
    '// Specify first row and column of database name field
    Set srcRng = wsData.Range("A2")
    
    '// Returns range from Start to last row in column
    Set srcRng = wsData.Range(srcRng, _
                        wsData.Cells(Rows.Count, srcRng.Column).End(xlUp))
    '// Change default error handling as find and findnext error when what
    '//  is not found.
    On Error Resume Next
    '// Set search after to first cell in search range
    Set srcAfter = srcRng(1, 1)
    
    Set foundRng = srcRng.Find(What:=criteriaVal, _
                                After:=srcAfter, _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                Searchorder:=xlByRows)
                                
    '// Criteria is not in data sheet
    If foundRng Is Nothing Then Exit Sub
    
    '// Set found range's entire row to copy range
    Set copyRng = foundRng.EntireRow
    
    '// First found in range of to prevent double finding.
    firstFound = foundRng.Row
    
    Do While True
        '// Set Find after to one cell below found cell
        Set srcAfter = foundRng.Offset(1, 0)
        '// Set found to default for testing
        Set foundRng = Nothing
        '// Find next occurence of criteria in search range
        '//  • if not found will error and resume next and remain nothing.
        '//  • otherwise it will return the cell range it was found in
        Set foundRng = srcRng.FindNext(After:=srcAfter)
        '// Test if it was not found "Is Nothing"
        '// • or it has looped around to beginning
        If foundRng Is Nothing Or firstFound = foundRng.Row Then Exit Do
        '// Join the last found with the previous found
        Set copyRng = Union(copyRng, foundRng.EntireRow)
    Loop
    '// Return to defult error handling
    On Error GoTo 0
    '// Copy and paste found ranges into report worksheet
    copyRng.Copy wsReport.Cells(OutputRow, 1)

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub