VBA Help - Trying to take data from a Master Sheet and copy rows based on specific column values

D

dualwieldbacon

New Member
Joined
May 11, 2021
Messages
8
Office Version
  1. 2016
Platform
  1. Windows
Hi all!

Very new to VBA here and I'm quite impressed with what it can do. I'm trying to set up a template and would like to automate as much as possible. In my master sheet, I have headings in the first row that spans columns A to W. Column V has two options for my data rows: 'Email' and 'Send'. When I input my data, I would like all rows that contain the trigger word 'Email' in Column V to be copied onto my sheet labelled 'Email List'. Similarly, I'd like the rows that contain the trigger word 'Mail' to be copied onto another third sheet called 'Send List'. In my master sheet, I also have a column W (called 'Assigned To') where I want to be able to enter either 'J' or 'A'; if it contains 'J' or 'A', I want that row to be copied onto a 4th sheet called 'Call List'.

I would like to retain all the data in my master sheet once it has been moved over to the appropriate sheet, so it does not get deleted. Any help is appreciated!
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
Hi dualwieldbacon, welcome to the MrExcel forum.

Does this come close to what you want to do. Please note that every time you run this code it will clear out all sheets but "Master" and rebuild them.

VBA Code: 
Sub CopyRows()

    Dim str As String
    Dim i As Long, x As Long, lRow As Long
    Dim wsM As Worksheet: Set wsM = Worksheets("Master")
    Dim wsE As Worksheet: Set wsE = Worksheets("Email List")
    Dim wsS  As Worksheet: Set wsS = Worksheets("Send List")
    Dim wsC As Worksheet: Set wsC = Worksheets("Call List")
    
    Application.ScreenUpdating = False
    
    wsE.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsS.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsC.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    For x = 21 To 23
        For i = 2 To wsM.Cells(Rows.Count, 1).End(xlUp).Row
            str = Cells(i, x)
            Select Case str
                Case Is = "Email"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsE.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsE.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "Mail"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsS.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsS.Range("A" & lRow).PasteSpecial xlPasteAll
            End Select
        Next
        Application.CutCopyMode = False
    Next

    For i = 2 To wsM.Cells(Rows.Count, 1).End(xlUp).Row
        str = Cells(i, 23)
        Select Case str
            Case Is = "J"
                wsM.Range("A" & i).EntireRow.Copy
                lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                wsC.Range("A" & lRow).PasteSpecial xlPasteAll
            Case Is = "A"
                wsM.Range("A" & i).EntireRow.Copy
                lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                wsC.Range("A" & lRow).PasteSpecial xlPasteAll
            End Select
        Application.CutCopyMode = False
    Next
    
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
igold said:
Hi dualwieldbacon, welcome to the MrExcel forum.

Does this come close to what you want to do. Please note that every time you run this code it will clear out all sheets but "Master" and rebuild them.

VBA Code: 
Sub CopyRows()

    Dim str As String
    Dim i As Long, x As Long, lRow As Long
    Dim wsM As Worksheet: Set wsM = Worksheets("Master")
    Dim wsE As Worksheet: Set wsE = Worksheets("Email List")
    Dim wsS  As Worksheet: Set wsS = Worksheets("Send List")
    Dim wsC As Worksheet: Set wsC = Worksheets("Call List")
   
    Application.ScreenUpdating = False
   
    wsE.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsS.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsC.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    For x = 21 To 23
        For i = 2 To wsM.Cells(Rows.Count, 1).End(xlUp).Row
            str = Cells(i, x)
            Select Case str
                Case Is = "Email"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsE.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsE.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "Mail"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsS.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsS.Range("A" & lRow).PasteSpecial xlPasteAll
            End Select
        Next
        Application.CutCopyMode = False
    Next

    For i = 2 To wsM.Cells(Rows.Count, 1).End(xlUp).Row
        str = Cells(i, 23)
        Select Case str
            Case Is = "J"
                wsM.Range("A" & i).EntireRow.Copy
                lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                wsC.Range("A" & lRow).PasteSpecial xlPasteAll
            Case Is = "A"
                wsM.Range("A" & i).EntireRow.Copy
                lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                wsC.Range("A" & lRow).PasteSpecial xlPasteAll
            End Select
        Application.CutCopyMode = False
    Next
   
    Application.ScreenUpdating = True
   
End Sub
Click to expand...

That works near perfectly, igold! Thank you so much!

One issue I'm having however is that when I note the rows in the Master sheet with 'J' or 'A' to assign it to the specific individual, I can see this column in both the 'Email List' and 'Send List' sheets. How can I have it so that it only appears in the 4th sheet 'Call List'?
 
Upvote 0
Is this better...

VBA Code: 
Sub CopyRows()

    Dim str As String
    Dim i As Long, x As Long, lRow As Long
    Dim wsM As Worksheet: Set wsM = Worksheets("Master")
    Dim wsE As Worksheet: Set wsE = Worksheets("Email List")
    Dim wsS  As Worksheet: Set wsS = Worksheets("Send List")
    Dim wsC As Worksheet: Set wsC = Worksheets("Call List")
    
    Application.ScreenUpdating = False
    
    wsE.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsS.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsC.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    For x = 23 To 21 Step -1
        For i = 2 To wsM.Cells(Rows.Count, 1).End(xlUp).Row
            str = Cells(i, x)
            Select Case str
                Case Is = "J"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsC.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "A"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsC.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "Email"
                        If Cells(i, 23) = "J" Or Cells(i, 23) = "A" Then GoTo JA
                        wsM.Range("A" & i).EntireRow.Copy
                        lRow = wsE.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsE.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "Mail"
                        If Cells(i, 23) = "J" Or Cells(i, 23) = "A" Then GoTo JA
                        wsM.Range("A" & i).EntireRow.Copy
                        lRow = wsS.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        wsS.Range("A" & lRow).PasteSpecial xlPasteAll
JA:
            End Select
        Next
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
igold said:
Is this better...

VBA Code: 
Sub CopyRows()

    Dim str As String
    Dim i As Long, x As Long, lRow As Long
    Dim wsM As Worksheet: Set wsM = Worksheets("Master")
    Dim wsE As Worksheet: Set wsE = Worksheets("Email List")
    Dim wsS  As Worksheet: Set wsS = Worksheets("Send List")
    Dim wsC As Worksheet: Set wsC = Worksheets("Call List")
   
    Application.ScreenUpdating = False
   
    wsE.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsS.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    wsC.Range("A2:W" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    For x = 23 To 21 Step -1
        For i = 2 To wsM.Cells(Rows.Count, 1).End(xlUp).Row
            str = Cells(i, x)
            Select Case str
                Case Is = "J"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsC.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "A"
                    wsM.Range("A" & i).EntireRow.Copy
                    lRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsC.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "Email"
                        If Cells(i, 23) = "J" Or Cells(i, 23) = "A" Then GoTo JA
                        wsM.Range("A" & i).EntireRow.Copy
                        lRow = wsE.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    wsE.Range("A" & lRow).PasteSpecial xlPasteAll
                Case Is = "Mail"
                        If Cells(i, 23) = "J" Or Cells(i, 23) = "A" Then GoTo JA
                        wsM.Range("A" & i).EntireRow.Copy
                        lRow = wsS.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        wsS.Range("A" & lRow).PasteSpecial xlPasteAll
JA:
            End Select
        Next
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
   
End Sub
Click to expand...

Hmmm, now it seems to only copy all the rows I've denoted as 'J' or 'A' into the 4th sheet, 'Call List'. The rows I've marked as 'Email' or 'Mail' do not show up in the 'Email List' or 'Send List' sheets.
 
Upvote 0
It did work perfectly for me as per your requirements. Are you sure that the data in the columns match exactly to what the code is looking for. If not change the code to what is in the columns. Can you post a small sample of your data.
 
Upvote 0
dualwieldbacon said:
One issue I'm having however is that when I note the rows in the Master sheet with 'J' or 'A' to assign it to the specific individual, I can see this column in both the 'Email List' and 'Send List' sheets. How can I have it so that it only appears in the 4th sheet 'Call List'?
Click to expand...
As per this statement in your Post #3, the template you uploaded has a "J" or an "A" in every line, therefore those lines only show on the Call List
 
Upvote 0
igold said:
As per this statement in your Post #3, the template you uploaded has a "J" or an "A" in every line, therefore those lines only show on the Call List
Click to expand...

I played around with the first code you shared and I was able to achieve just what I wanted! Turns out that hiding columns was an easy way to solve this. Thanks again, igold!
 
Upvote 0
You are welcome, I was happy to help. Thanks for the feedback.

When I looked at your template, I noticed you had the code placed in the Master Worksheet Module. You should move the code into the empty Module1 as mostly all code should be put into Code Modules (such as Module1) and not in Worksheet Modules.
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question Question
Excel Help with VBA Code
Replies
6
Views
138
mumps
mumps
S
  • Question Question
Copy certain column N number of times
Replies
0
Views
233
sm789
S
S
  • Question Question
VBA Code that extracts multiple tabs at a time based on lookup tab
2
Replies
10
Views
430
NoSparks
N
Y
  • Question Question
Consolidate all values from specific sheets into 1 master excel file
Replies
1
Views
165
Trebor76
T
A
  • Solved
Copy Entire Workbook, save as sheet name with current date, hide all sheets except one, & attach to email
Replies
2
Views
529
Amo840812
A

Forum statistics

Threads
1,223,721
Messages
6,174,097
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top