Macro to copy and paste rows based on criteria

Glenno · Jul 10, 2018

Hi, i have seen similar threads but not exactly what i am looking for. Most copy from multiple sheets to one sheet, i am trying to go in reverse of that. I have uploaded the file in question, which is a list of all tenders we are advised of, then criteria to determine which ones my company wants to pursue.
What I want to do is as follows-

columns A-G will be entered by our admin, free text under headings at Row 5
Columns H thru O will be calculated by drop down menu with a score at the end to decide whether it is worth our business pursuing
Depending on a score above 27 in column P-Q, we then add a Salesperson in Column R from a drop down menu as the responsible person to follow up.
We would then have an ActiveX button, that once pressed searches each of the salesperson initials, and for example if Column R was populated with the initials PT, it would loop thru the whole list and copy every row with PT in Column R into the worksheet entitled Salesperson PT.
the same for Salesperson GB into the worksheet entitled Salesperson GB, and so forth, adding a line under the previous line on the Salesperson worksheets but ignoring lines that are already listed.
I don't want it to delete the entry on the Tender Listing sheet, just copy the details to the salesperson worksheets based on the initials.

AlanSidman · Jul 10, 2018

Code:

Option Explicit

Sub Glenno()
    Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, s4 As Worksheet
    Dim s5 As Worksheet, s6 As Worksheet, s7 As Worksheet, s8 As Worksheet, s9 As Worksheet
    Set s1 = Sheets("Tender Listing")
    Set s2 = Sheets("Salesperson PT")
    Set s3 = Sheets("Salesperson GB")
    Set s4 = Sheets("Salesperson GM")
    Set s5 = Sheets("Salesperson DS")
    Set s6 = Sheets("Salesperson MS")
    Set s7 = Sheets("Salesperson GC")
    Set s8 = Sheets("Salesperson NB")
    Set s9 = Sheets("Salesperson CA")
    Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, lr8 As Long, lr9 As Long
    lr1 = s1.Range("R" & Rows.Count).End(xlUp).Row
    Dim i As Long
    Application.ScreenUpdating = False
    For i = 7 To lr1
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        lr3 = s3.Range("A" & Rows.Count).End(xlUp).Row
        lr4 = s4.Range("A" & Rows.Count).End(xlUp).Row
        lr5 = s5.Range("A" & Rows.Count).End(xlUp).Row
        lr6 = s6.Range("A" & Rows.Count).End(xlUp).Row
        lr7 = s7.Range("A" & Rows.Count).End(xlUp).Row
        lr8 = s8.Range("A" & Rows.Count).End(xlUp).Row
        lr9 = s9.Range("A" & Rows.Count).End(xlUp).Row
        Select Case s1.Range("R" & i).Value2
        Case "PT"
            s1.Range("A" & i & ":Q" & i).Copy
            s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
        Case "GB"
            s1.Range("A" & i & ":Q" & i).Copy
            s3.Range("A" & lr3 + 1).PasteSpecial xlPasteValues
        Case "GM"
            s1.Range("A" & i & ":Q" & i).Copy
            s4.Range("A" & lr4 + 1).PasteSpecial xlPasteValues
        Case "DS"
            s1.Range("A" & i & ":Q" & i).Copy
            s5.Range("A" & lr5 + 1).PasteSpecial xlPasteValues
        Case "MS"
            s1.Range("A" & i & ":Q" & i).Copy
            s6.Range("A" & lr6 + 1).PasteSpecial xlPasteValues
        Case "GC"
            s1.Range("A" & i & ":Q" & i).Copy
            s7.Range("A" & lr7 + 1).PasteSpecial xlPasteValues
        Case "NB"
            s1.Range("A" & i & ":Q" & i).Copy
            s8.Range("A" & lr8 + 1).PasteSpecial xlPasteValues
        Case "CA"
            s1.Range("A" & i & ":Q" & i).Copy
            s9.Range("A" & lr9 + 1).PasteSpecial xlPasteValues
        End Select
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Action Completed"
End Sub

Glenno · Jul 11, 2018

Mate, that is absolutely brilliant thank you. i think part of my failed attempts was that i had multiple sets of initials but not matching multiple pages.

However, i have found one issue in that each time i run the macro it copies a previously copied row again, and adds it to the list on each worksheet (per attached). how do i fix that please so that it only copies a row once no matter how many times the macro has been run?

AlanSidman · Jul 12, 2018

The only way I see that happening is to clear all data from the sub sheets prior to running the VBA. This can be incorporated into the current macro. The issue with doing what you want based upon new data entry would require a Worksheet_Change Event, but the problem with that is you are using a drop down validation that a Worksheet_change Event will not recognize as a change event in Column R. So, in order for it to happen without a clearing of the existing data would be to eliminate the drop down and have a manual entry for that item. Tell me which way you wish to go on this and I will amend the existing code to make it happen.

Glenno · Jul 12, 2018

very much appreciate your help, thank you. I am still learning (obviously) but getting better with the help of people like yourself.
I think i would prefer to clear the sub sheets and repopulate each time. A little bit longer time as the list grows would not be an issue, however people reading multiple rows of the same data might be. Typo's when entering initials might be an issue to hence wanting to keep the drop down in column R

thanks again

AlanSidman · Jul 12, 2018

Code:

Option Explicit

Sub Glenno()
    Dim ws As Worksheet, lr As Long, lc As Long
    Application.ScreenUpdating = False
        For Each ws In Worksheets
            If ws.Name <> "Tender Listing" Then
                lr = ws.Range("A" & Rows.Count).End(xlUp).Row
                lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
                ws.Range(Cells(2, 1), Cells(lr, lc)).ClearContents
            End If
        Next ws
   
    Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, s4 As Worksheet
    Dim s5 As Worksheet, s6 As Worksheet, s7 As Worksheet, s8 As Worksheet, s9 As Worksheet
    Set s1 = Sheets("Tender Listing")
    Set s2 = Sheets("Salesperson PT")
    Set s3 = Sheets("Salesperson GB")
    Set s4 = Sheets("Salesperson GM")
    Set s5 = Sheets("Salesperson DS")
    Set s6 = Sheets("Salesperson MS")
    Set s7 = Sheets("Salesperson GC")
    Set s8 = Sheets("Salesperson NB")
    Set s9 = Sheets("Salesperson CA")
    Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, lr8 As Long, lr9 As Long
    lr1 = s1.Range("R" & Rows.Count).End(xlUp).Row
    Dim i As Long
    Application.ScreenUpdating = False
    For i = 7 To lr1
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        lr3 = s3.Range("A" & Rows.Count).End(xlUp).Row
        lr4 = s4.Range("A" & Rows.Count).End(xlUp).Row
        lr5 = s5.Range("A" & Rows.Count).End(xlUp).Row
        lr6 = s6.Range("A" & Rows.Count).End(xlUp).Row
        lr7 = s7.Range("A" & Rows.Count).End(xlUp).Row
        lr8 = s8.Range("A" & Rows.Count).End(xlUp).Row
        lr9 = s9.Range("A" & Rows.Count).End(xlUp).Row
        Select Case s1.Range("R" & i).Value2
        Case "PT"
            s1.Range("A" & i & ":Q" & i).Copy
            s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
        Case "GB"
            s1.Range("A" & i & ":Q" & i).Copy
            s3.Range("A" & lr3 + 1).PasteSpecial xlPasteValues
        Case "GM"
            s1.Range("A" & i & ":Q" & i).Copy
            s4.Range("A" & lr4 + 1).PasteSpecial xlPasteValues
        Case "DS"
            s1.Range("A" & i & ":Q" & i).Copy
            s5.Range("A" & lr5 + 1).PasteSpecial xlPasteValues
        Case "MS"
            s1.Range("A" & i & ":Q" & i).Copy
            s6.Range("A" & lr6 + 1).PasteSpecial xlPasteValues
        Case "GC"
            s1.Range("A" & i & ":Q" & i).Copy
            s7.Range("A" & lr7 + 1).PasteSpecial xlPasteValues
        Case "NB"
            s1.Range("A" & i & ":Q" & i).Copy
            s8.Range("A" & lr8 + 1).PasteSpecial xlPasteValues
        Case "CA"
            s1.Range("A" & i & ":Q" & i).Copy
            s9.Range("A" & lr9 + 1).PasteSpecial xlPasteValues
        End Select
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Action Completed"
End Sub

Glenno · Jul 15, 2018

hi Alan, tried to apply the revised Macro but it came up with this

i had redone the sheet as the tabs numbering was slightly different to my original numbering meaning the original macro had to be modified slightly, but now i'm not sure what to do. the new file is uploaded to

AlanSidman · Jul 16, 2018

Do you get an error message? I don't understand what you have indicated is the issue. Please explain in the thread what the issue is. Why is the line of code highlighted in yellow. Do you get an error message? If so, what is the error message?

Marc L · Jul 16, 2018

Hi !

Glenno said:
i had redone the sheet as the tabs numbering was slightly different

According to your last attachment just with Excel basics
as a beginner starter :

Code:

Sub Demo1()
        Dim Rg(2) As Range, N&, S$()
    With Sheet1.UsedRange.Rows
        Set Rg(0) = .Item("1:4")
        Set Rg(1) = .Range("Z1:Z2")
        Set Rg(2) = .Item("5:" & .Count)
        Rg(1)(1).Value = .Range("R5").Value
    End With
        Application.ScreenUpdating = False
    For N = 2 To Worksheets.Count - 1
        With Worksheets(N)
                S = Split(.Name)
            If UBound(S) = 1 Then
               .UsedRange.Clear
                Rg(0).Copy .Cells(1)
                Rg(1)(2).Value = S(1)
                Rg(2).AdvancedFilter xlFilterCopy, Rg(1), .[A5]
            End If
        End With
    Next
        Rg(1).Clear
        Erase Rg
        Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !

Glenno · Jul 16, 2018

thanks Alan,

i didn't do anything unusual, (that i know of anyway

. I created the module, cut and pasted the macro into the module, inserted a Form button (top of ws1), assigned the macro, saved it, then tried to run it. i tried to debug it first and got the yellow highlighted line appear.

I have attached the file again with the macro added. When i execute it, i initially get a window with Run-Time error '1004', press debug and get the same as the previous post, ie: the yellow highlighted line.

AlanSidman · Jul 17, 2018

That is because there is no data to clear in the range selected. Suggest you put the header that you have in the First sheet in all the sub sheets to start. I noticed also that you had removed a salesperson so I have modified the code

Code:

Option Explicit

Sub Glenno()
    Dim ws As Worksheet, lr As Long, lc As Long
    Application.ScreenUpdating = False
        For Each ws In Worksheets
            If ws.Name <> "Tender Listing" Then
                lr = ws.Range("A" & Rows.Count).End(xlUp).Row
                lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
                If ws.Range("A2") <> "" Then
                ws.Range(Cells(2, 1), Cells(lr, lc)).ClearContents
                End If
            End If
           
        Next ws
 
    Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, s4 As Worksheet
    Dim s5 As Worksheet, s6 As Worksheet, s8 As Worksheet, s9 As Worksheet
    Set s1 = Sheets("Tender Listing")
    Set s2 = Sheets("Salesperson PT")
    Set s3 = Sheets("Salesperson GB")
    Set s4 = Sheets("Salesperson GM")
    Set s5 = Sheets("Salesperson DS")
    Set s6 = Sheets("Salesperson MS")
    'Set s7 = Sheets("Salesperson GC")
    Set s8 = Sheets("Salesperson NB")
    Set s9 = Sheets("Salesperson CA")
    Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, lr8 As Long, lr9 As Long
    lr1 = s1.Range("R" & Rows.Count).End(xlUp).Row
    Dim i As Long
    Application.ScreenUpdating = False
    For i = 7 To lr1
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        lr3 = s3.Range("A" & Rows.Count).End(xlUp).Row
        lr4 = s4.Range("A" & Rows.Count).End(xlUp).Row
        lr5 = s5.Range("A" & Rows.Count).End(xlUp).Row
        lr6 = s6.Range("A" & Rows.Count).End(xlUp).Row
        'lr7 = s7.Range("A" & Rows.Count).End(xlUp).Row
        lr8 = s8.Range("A" & Rows.Count).End(xlUp).Row
        lr9 = s9.Range("A" & Rows.Count).End(xlUp).Row
        Select Case s1.Range("R" & i).Value2
        Case "PT"
            s1.Range("A" & i & ":Q" & i).Copy
            s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
        Case "GB"
            s1.Range("A" & i & ":Q" & i).Copy
            s3.Range("A" & lr3 + 1).PasteSpecial xlPasteValues
        Case "GM"
            s1.Range("A" & i & ":Q" & i).Copy
            s4.Range("A" & lr4 + 1).PasteSpecial xlPasteValues
        Case "DS"
            s1.Range("A" & i & ":Q" & i).Copy
            s5.Range("A" & lr5 + 1).PasteSpecial xlPasteValues
        Case "MS"
            s1.Range("A" & i & ":Q" & i).Copy
            s6.Range("A" & lr6 + 1).PasteSpecial xlPasteValues
        'Case "GC"
            's1.Range("A" & i & ":Q" & i).Copy
            's7.Range("A" & lr7 + 1).PasteSpecial xlPasteValues
        Case "NB"
            s1.Range("A" & i & ":Q" & i).Copy
            s8.Range("A" & lr8 + 1).PasteSpecial xlPasteValues
        Case "CA"
            s1.Range("A" & i & ":Q" & i).Copy
            s9.Range("A" & lr9 + 1).PasteSpecial xlPasteValues
        End Select
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Action Completed"
End Sub

Glenno · Jul 17, 2018

thanks again Alan, just a short question if i may. i notice that all references to ws7 have an apostrophe in front of them, and then immediately after ws 7, ws8 is out dented. Firstly, why is this the case, and secondly what do i have to do to add back in the removed one (GC) given that it would become ws 10

Marc L · Jul 17, 2018

Glenno said:
When i execute it, i initially get a window with Run-Time error '1004'

AlanSidman said:
That is because there is no data to clear in the range selected.

No, it's just a logic issue from a missing worksheet reference :

Range(ws.Cells(2, 1), ws.Cells(lr, lc)).ClearContents …

AlanSidman · Jul 17, 2018

The apostrophe removes the line of code from use. It makes the line a comment. You have no sheet for what was formerly s7. So I removed it from the Dimension line and commented it our in the rest of the code. It can be added back if you have a sheet that it will represent by removing the apostrophe and Dimensioning the sheet as is done for the other sheets.

Glenno · Jul 19, 2018

sorry guys, i tried to get it to work but it wont run at all now

AlanSidman · Jul 19, 2018

Well, you changed up the worksheet again. VBA does not work with merged cells. You have merged columns R and S. This is a no-no in VBA. Unmerge them. You have also moved (this is critical) the lookup values to column T. In the code in your original post, the look up values are in Column R which is what the code is directing. If you expect help here, you cannot be changing things up to your workbook after the code has been provided. You must provide what you will be working with so that we are not running in circles. You will either have to fix the code to look at column T or change back to Column R and unmerge your cells.

Marc L · Jul 19, 2018

According to last attachment, Demo1 codelines to mod at child level :

• #4 : Set Rg(0) = .Item("1:3")

• #6 : Set Rg(2) = .Item("4:" & .Count)

• #7 : Rg(1)(1).Value = .Range("T4").Value

• change [A5] to [A4] in codeline #17

Any mod can be avoided just using a named range ! (Excel basics)

A smart worksheet do not need any merged cells, headers in row #1 …

Macro to copy and paste rows based on criteria

Glenno

New Member

Attachments

AlanSidman

Well-Known Member

Glenno

New Member

Attachments

AlanSidman

Well-Known Member

Glenno

New Member

AlanSidman

Well-Known Member

Glenno

New Member

Attachments

AlanSidman

Well-Known Member

Marc L

Excel Ninja

Glenno

New Member

Attachments

AlanSidman

Well-Known Member

Glenno

New Member

Marc L

Excel Ninja

AlanSidman

Well-Known Member

Glenno

New Member

Attachments

AlanSidman

Well-Known Member

Marc L

Excel Ninja