Macro to seperate data

[Tony]

Hi

I seem to be struggling to find a macro that will work in previous threads.

In sheet 1 is a list of data in columns A:N and the number of rows will
vary. It is a list of sales with each sale record ocuppying one row. The
salesperson's name is in column C and each salesperson will have multiple
entries.

What I am trying to do is create a seperate summary sheet in the workbook
for each salesperson. Therefore sheets 2 to 20 are templates that already
exist with a different salesperson's name entered into cell C3 on each of
them.

I am trying to find a macro that will copy each row from sheet 1 where the
salesperson's name in column C matches the value (salesperson's name) entered
into C3 on one of the sheets 2-20.

Any help would be most appreciated.
Thanks

 

[Mike H]

Tony,

try this

Sub stance()
Dim MyRange As Range
Dim CopyRange As Range
Dim LastRow As Long
LastRow = Sheets("Sheet1").Cells(Cells.Rows.Count, "C").End(xlUp).Row
Set MyRange = Sheets("Sheet1").Range("C1:C" & LastRow)
For x = 2 To 20
For Each c In MyRange
If UCase(c.Value) = UCase(Sheets(x).Range("C3")) Then
If CopyRange Is Nothing Then
Set CopyRange = c.EntireRow
Else
Set CopyRange = Union(CopyRange, c.EntireRow)
End If
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets(x).Range("A4")
Set CopyRange = Nothing
End If
Next x
End Sub


Mike
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Mike H]

Just noticed you want rows A- N and not the entire row, use this instead

Sub stance()
Dim MyRange As Range
Dim CopyRange As Range
Dim LastRow As Long
LastRow = Sheets("Sheet1").Cells(Cells.Rows.Count, "C").End(xlUp).Row
Set MyRange = Sheets("Sheet1").Range("C1:C" & LastRow)
For x = 2 To 4
For Each c In MyRange
If UCase(c.Value) = UCase(Sheets(x).Range("C3")) Then
If CopyRange Is Nothing Then
Set CopyRange = c.Offset(0, -2).Resize(, 14)
Else
Set CopyRange = Union(CopyRange, c.Offset(0, -2).Resize(, 14))
End If
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets(x).Range("A4")
Set CopyRange = Nothing
End If
Next x
End Sub

Mike
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Mike H]

oops,

left my shortened loop that i used for testing
For x = 2 To 4
should be
For x = 2 To 20
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Tony]

Mike you are a genius, thanks very much for your help.

Tony

 

[Mike H]

Genious may be OTT but glad I could help
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.