Copying rows based on criteria

**suedavies** · 12-05-2016, 10:26 AM

Hi
I want to use VBA code to auto populate sheets with the data from my mastersheet based on the criteria shown in column A, I've managed to get most of it working but we need to retain the data on the master sheet and at the moment I am duplicating the entries on the second sheets.

i have attached a dummy example of what I am trying to do

Many thanks

Sue

**Marc L** · 12-05-2016, 10:41 AM

Hi !

You can use the easy advanced filter method to directly filter and copy data …

**suedavies** · 12-05-2016, 10:52 AM

thank you but we want to be able to automate the process and not have to do filters and then copy paste - I presume this is what you mean to do

thanks

Sue

**suedavies** · 12-05-2016, 11:31 AM

Hi Marc L I'm trying the advanced filter but it's testing my brain

**mike7952** · 12-05-2016, 06:42 PM

Is this what your wanting?

Option Explicit
Private Sub CommandButton1_Click()
 Dim shName As String, cFind As Range
 Dim sh As Worksheet, lr As Long, c As Range
 
 Set sh = Sheets("MasterSheet")
 lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
 For Each c In sh.Range("a2:a" & lr)
    Select Case c.Value
        Case Is = "AAAA"
            shName = "Centre1"
        Case Is = "BBBB"
            shName = "Centre2"
        Case Is = "XXXX"
            shName = "Centre3"
        Case Is = "YYYY"
            shName = "Centre4"
        Case Is = "ZZZZ"
            shName = "Centre5"
    End Select
    With Worksheets(shName).Columns(1)
        Set cFind = .Find(c.Offset(, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        If cFind Is Nothing Then
            .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = _
                c.Offset(, 1).Resize(, 3).Value
        End If
    End With
 Next
End Sub

**suedavies** · 12-06-2016, 04:58 AM

Mike7952 - thankyou - you are amazing

**mike7952** · 12-05-2016, 06:50 PM

Is this what your wanting?

Option Explicit
Private Sub CommandButton1_Click()
 Dim shName As String, cFind As Range
 Dim sh As Worksheet, lr As Long, c As Range
 
 Set sh = Sheets("MasterSheet")
 lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
 For Each c In sh.Range("a2:a" & lr)
    Select Case c.Value
        Case Is = "AAAA"
            shName = "Centre1"
        Case Is = "BBBB"
            shName = "Centre2"
        Case Is = "XXXX"
            shName = "Centre3"
        Case Is = "YYYY"
            shName = "Centre4"
        Case Is = "ZZZZ"
            shName = "Centre5"
    End Select
    With Worksheets(shName).Columns(1)
        Set cFind = .Find(c.Offset(, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        If cFind Is Nothing Then
            .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = _
                c.Offset(, 1).Resize(, 3).Value
        End If
    End With
 Next
End Sub

**suedavies** · 12-06-2016, 06:29 AM

Sorry Mike7952 I have one more query, see attached sheet - If I want to add more columns for example for addresses how do I change the code to copy over the complete row, I envisage adding more data to the mastersheet

Many thanks

Sue

**mike7952** · 12-06-2016, 11:44 AM

This will work, see highlighted changes

Option Explicit
Private Sub CommandButton1_Click()
 Dim shName As String, cFind As Range
 Dim sh As Worksheet, lr As Long, c As Range
 
 Set sh = Sheets("MasterSheet")
 lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
 For Each c In sh.Range("a2:a" & lr)
    Select Case c.Value
        Case Is = "AAAA"
            shName = "Centre1"
        Case Is = "BBBB"
            shName = "Centre2"
        Case Is = "XXXX"
            shName = "Centre3"
        Case Is = "YYYY"
            shName = "Centre4"
        Case Is = "ZZZZ"
            shName = "Centre5"
    End Select
    With Worksheets(shName).Columns(1)
        Set cFind = .Find(c.Offset(, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        If cFind Is Nothing Then
            .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 7).Value = _
                c.Offset(, 1).Resize(, 7).Value
        End If
    End With
 Next
End Sub

**suedavies** · 12-06-2016, 02:16 PM

Thank you Mike7952 that is amazing

Copying rows based on criteria

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Re: Copying rows based on criteria

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Macro for copying rows in sheet1 to end of existing rows in sheet2 based on criteria

Copying rows into new workbook, based on set criteria

[SOLVED] Copying Rows of Data Based on Criteria

Copying rows from another sheet based on specific criteria

Excel 2007 : Copying rows from one sheet to another based on matched criteria

Copying rows in range based on criteria

Copying whole rows based upon one criteria

Bookmarks

Bookmarks

Posting Permissions