0

I am hoping someone has a way to significantly decrease the time that the below code takes to complete. I have a worksheet which has code to open a file and import data from that file. No issues there. The below code will then search column A for a particular persons name, when that persons name is found it will cut and paste that row into that persons corresponding worksheet. This code takes minutes to execute. Each row will always have data in column A,B,&C. Columns D,E,F may or may not contain dates in them. Currently the import file has around 1200 rows and will be increasing. Anyway to increase the efficiency of this action being done?

Private Sub CommandButton1_Click()
    Dim sh As Worksheet, ws As Worksheet
    Dim rws As Long, rng As Range, c As Range

    Set sh = Worksheets("data")
    Set aa = Worksheets("aamory")
    Set bg = Worksheets("bglesing")
    Set da = Worksheets("damory")
    Set Db = Worksheets("dbutzer")
    Set dd = Worksheets("ddelnero")
    Set dm = Worksheets("dmacmaster")
    Set er = Worksheets("erose")
    Set gr = Worksheets("gragonese")
    Set jg = Worksheets("jgabbard")
    Set lw = Worksheets("lwhite")
    Set kc = Worksheets("kcarter")
    Set lw = Worksheets("lwhite")
    Set mb = Worksheets("mbrooks")
    Set rg = Worksheets("rgallese")
    Set sp = Worksheets("spolk")
    Set sb = Worksheets("sbrooks")

    With sh
        rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set rng = .Range(.Cells(1, 1), .Cells(rws, 1))
    End With

    For Each c In rng.Cells

        If c = "aamory" Then
            c.EntireRow.Cut Destination:=aa.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "bglesing" Then
            c.EntireRow.Cut Destination:=bg.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "damory" Then
            c.EntireRow.Cut Destination:=da.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "dbutzer" Then
            c.EntireRow.Cut Destination:=Db.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "ddelnero" Then
            c.EntireRow.Cut Destination:=dd.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "dmacmaster" Then
            c.EntireRow.Cut Destination:=dm.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "erose" Then
            c.EntireRow.Cut Destination:=er.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "gragonese" Then
            c.EntireRow.Cut Destination:=gr.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "jgabbard" Then
            c.EntireRow.Cut Destination:=jg.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "lwhite" Then
            c.EntireRow.Cut Destination:=lw.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "kcarter" Then
            c.EntireRow.Cut Destination:=kc.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "mbrooks" Then
            c.EntireRow.Cut Destination:=mb.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "rgallese" Then
            c.EntireRow.Cut Destination:=rg.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "spolk" Then
            c.EntireRow.Cut Destination:=sp.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "sbrooks" Then
            c.EntireRow.Cut Destination:=sb.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If

       Next c
Application.ScreenUpdating = True
End Sub
Grags
  • 1
  • 1
  • 2
    This would be more suited for https://codereview.stackexchange.com/. – Warcupine Jan 23 '20 at 15:01
  • Use a filter instead. Create an array of the names, then loop through each element, filter the original table, copy the visible cells, and paste them on the corresponding sheet. Then you can clear the original table at the end. – BigBen Jan 23 '20 at 15:01
  • If you run this code, does the input file end up blank because the entire range has been cut to other worksheets? As BigBen states, you can handle this more efficiently if you divide your data up first, and then delete everything at once after. – Plutian Jan 23 '20 at 15:02
  • 1
    Using a case statement or elseifs is probably faster since if it matches one it won't check against the rest. – Warcupine Jan 23 '20 at 15:03
  • 1
    [`Application.Calculation`](https://learn.microsoft.com/en-us/office/vba/api/excel.application.calculation) might be useful – Chronocidal Jan 23 '20 at 15:03
  • You can also say `destination:=worksheets(c).cells(rows.count)….` – Nathan_Sav Jan 23 '20 at 15:14
  • 1
    @Warcupine: Not actually. It is on topic for both sites. :) You may want to see [Please stop redirecting performance problems to Code Review](https://meta.stackoverflow.com/questions/388864/please-stop-redirecting-performance-problems-to-code-review) and [Performance question - Stack Overflow or Code Review?](https://meta.stackoverflow.com/questions/300981/performance-question-stack-overflow-or-code-review) and [Guidance on migrating questions to Code Review](https://meta.stackoverflow.com/questions/348395/guidance-on-migrating-questions-to-code-review) – Siddharth Rout Jan 23 '20 at 15:31
  • @SiddharthRout Interesting, first I've seen of that. I stand by that you are more likely to get your question answered on Code Review with this kind of question though. So i'll leave that comment for posterity. – Warcupine Jan 23 '20 at 15:35
  • A much faster way would be use AutoFilter to copy the data across in one go. You may want to see [How to copy a line in excel using a specific word and pasting to another excel sheet?](https://stackoverflow.com/questions/11631363/how-to-copy-a-line-in-excel-using-a-specific-word-and-pasting-to-another-excel-s/11633207#11633207) – Siddharth Rout Jan 23 '20 at 15:35
  • @Warcupine: Even I used to think that but was later corrected. If you have enough reputation then you will be able to see the [question](https://meta.stackoverflow.com/questions/390803/is-this-question-on-topic-for-code-review) that I had asked (now deleted) – Siddharth Rout Jan 23 '20 at 15:37
  • @SiddharthRout I referenced your link and implemented the code into the command button, which works great. Does that code have to be run per person or is there a way to have it copy over the other people into their cooresponding worksheet. Sorry if it a simple fix but my VB coding was good back in win 95. Today, not so much. – Grags Jan 23 '20 at 16:11
  • You can create one common procedure where you can pass cell value and destination sheet. Something like `Private Sub ProcessData(FilterString As String, ws as WorkSheet)` And then simply use `ProcessData "aamory",aa` and the autofilter code goes inside `ProcessData()` – Siddharth Rout Jan 23 '20 at 16:15
  • @SiddharthRout Almost have it working properly. I have been trying to change the code to cut each row instead of copy but have not had any luck. What line of code needs to change for that to happen? – Grags Jan 23 '20 at 16:53
  • 1
    You cannot cut non contiguous ranges. So **1.** Copy the filtered rows across **2.** Delete the filtered rows after copying – Siddharth Rout Jan 23 '20 at 16:56

0 Answers0