1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to copy and paste rows based on criteria

Discussion in 'VBA Macros' started by Glenno, Jul 10, 2018.

  1. Glenno

    Glenno New Member

    Messages:
    14
    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.

    Attached Files:

  2. AlanSidman

    AlanSidman Active Member

    Messages:
    307
    Code (vb):
    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

     
  3. Glenno

    Glenno New Member

    Messages:
    14
    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?

    Attached Files:

    • 1.JPG
      1.JPG
      File size:
      47.2 KB
      Views:
      2
    • 2.JPG
      2.JPG
      File size:
      94 KB
      Views:
      1
  4. AlanSidman

    AlanSidman Active Member

    Messages:
    307
    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.
  5. Glenno

    Glenno New Member

    Messages:
    14
    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
  6. AlanSidman

    AlanSidman Active Member

    Messages:
    307
    Code (vb):
    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
  7. Glenno

    Glenno New Member

    Messages:
    14
    hi Alan, tried to apply the revised Macro but it came up with this
    upload_2018-7-16_6-53-19.png

    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

    Attached Files:

  8. AlanSidman

    AlanSidman Active Member

    Messages:
    307
    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?
  9. Marc L

    Marc L Excel Ninja

    Messages:
    4,044
    Hi !
    According to your last attachment just with Excel basics
    as a beginner starter :​
    Code (vb):
    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 !
    Thomas Kuriakose likes this.
  10. Glenno

    Glenno New Member

    Messages:
    14
    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.

    Attached Files:

  11. AlanSidman

    AlanSidman Active Member

    Messages:
    307
    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 (vb):
    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
     
  12. Glenno

    Glenno New Member

    Messages:
    14
    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
  13. Marc L

    Marc L Excel Ninja

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

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

    AlanSidman Active Member

    Messages:
    307
    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.
  15. Glenno

    Glenno New Member

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

    Attached Files:

  16. AlanSidman

    AlanSidman Active Member

    Messages:
    307
    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 likes this.
  17. Marc L

    Marc L Excel Ninja

    Messages:
    4,044
    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 …
    Thomas Kuriakose likes this.

Share This Page