Copy from one shee to another, based on Criteria

[amorse2]

I have been researching this for awhile now, and can't figure out how to do it. Basically I have one sheet that has 23 columns - one of those columns being "Responsible Party". I want to ONLY copy the rows of data if the responsible Party has the name "Joe Smith" (for example). I do NOT want to use an autofilter - I know how to add that in macro - but instead would rather use a for loop. Any ideas.

Example of Sheet 2

Sales Office Responsible Party Company ID Company Name AUM (MM) Boston Joe Smith 12 Google 5 Boston Joe Smith 13 BlackRock 10 Boston Joe Smith 15 GE 52 Boston Dan Washington 78 StateStreet 90 Boston George Bard 92 BNY 100 <tbody> </tbody>
Below is what I want to show up on Sheet 1 (from Sheet 2 Above) USING A MACRO
Sales Office Responsible Party Company ID Company Name AUM (MM) Boston Joe Smith 12 Google 5 Boston Joe Smith 13 BlackRock 10 Boston Joe Smith 15 GE 52 <tbody> </tbody>
please help if you have any ideas!! I've tried multiple different ways.

<tbody>
</tbody><colgroup><col><col><col span="2"><col></colgroup>

 

[Redwolfx]

This is fairly fast.

It actually seperates Each Party into it's own sheet.

Add this to a Module:

Sub Macro1()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets(1).Range("A100000").End(xlUp).Row
For Each mycell In Range("B2:B" & LastRow)
Checksheet mycell.Value
Next mycell
For Each WS In ThisWorkbook.Worksheets
If WS.Index > WSCount Then
Cat = WS.Name

For Each mycell In Sheets(1).Range("B2:B" & LastRow)
If mycell.Value <> Cat Then
mycell.EntireRow.Hidden = True
End If
Next mycell

Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
End If
Sheets(1).Rows("1:" & LastRow).Hidden = False
Next WS

Application.ScreenUpdating = True
End Sub

Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
'Sets WSto for ongoing use
Set WSto = Sheets(mycell)
If Err <> 0 Then
Err.Clear
Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
WSto.Name = mycell
If Err <> 0 Then
GoTo Errhandler
End If
End If
On Error GoTo 0
Errhandler:
End Sub

 

[hiker95]

amorse2,

Welcome to the MrExcel forum.

What version of Excel and Windows are you using?

Are you using a PC or a MAC?


I assume that worksheets Sheet1 and Sheet2 already exist.

Sample worksheets:

Excel 2007
	A	B	C	D	E
1	Sales Office	Responsible Party	Company ID	Company Name	AUM (MM)
2	Boston	Joe Smith	12	Google	5
3	Boston	Joe Smith	13	BlackRock	10
4	Boston	Joe Smith	15	GE	52
5	Boston	Dan Washington	78	StateStreet	90
6	Boston	George Bard	92	BNY	100
7
Sheet2

Excel 2007
	A	B	C	D	E
1	Sales Office	Responsible Party	Company ID	Company Name	AUM (MM)
2
3
4
5
Sheet1

After the macro in worksheet Sheet1:

Excel 2007
	A	B	C	D	E
1	Sales Office	Responsible Party	Company ID	Company Name	AUM (MM)
2	Boston	Joe Smith	12	Google	5
3	Boston	Joe Smith	13	BlackRock	10
4	Boston	Joe Smith	15	GE	52
5
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub CopyJoeSmith()
' hiker95, 04/14/2014, ME771223
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, nr As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
With w1
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(, 5).Value = w2.Cells(1, 1).Resize(, 5).Value
  .Columns.AutoFit
End With
With w2
  For Each c In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    If c = "Joe Smith" Then
      nr = w1.Cells(Rows.Count, "A").End(xlUp).Row + 1
      w1.Cells(nr, 1).Resize(, 5).Value = .Cells(c.Row, 1).Resize(, 5).Value
    End If
  Next c
End With
With w1
  .Columns("A:W").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CopyJoeSmith macro.

 

[hiker95]

amorse2,

Basically I have one sheet that has 23 columns

I missed that part - be back in a little while.

 

[hiker95]

amorse2,

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub CopyJoeSmith_V2()
' hiker95, 04/14/2014, ME771223
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, nr As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
With w1
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(, 23).Value = w2.Cells(1, 1).Resize(, 23).Value
  .Columns.AutoFit
End With
With w2
  For Each c In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    If c = "Joe Smith" Then
      nr = w1.Cells(Rows.Count, "A").End(xlUp).Row + 1
      w1.Cells(nr, 1).Resize(, 23).Value = .Cells(c.Row, 1).Resize(, 23).Value
    End If
  Next c
End With
With w1
  .Columns("A:W").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CopyJoeSmith_V2 macro.

 

[amorse2]

Unfortunately this did not work. I had to change a few things based on WHERE I want the data to be placed - and therefore that could have caused some issues. Also, I don't really care about the sizing at all, because this data is going to be used for formulas later on. However, one part of the code that I don't see is where it is COPYING the data and then PASTING it on another sheet. Below is the code that I tried to use which did not work:

Sub CopySRMdata()
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, nr As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Score Card") 'want to paste specific SRM data on this sheet
Set w2 = Sheets("Sales by Country") 'where the ALL the data is that I want to copy
'clear contents on Score Card so it is blank before pasting new data
With w1
Range("AD2:AZ2").Select 'this range is where I want the SRM data to go
Range(Selection, Selection.End(xlDown)).Select
Selection.clearcontents
End With
With w2
For Each c In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
If c = "Joe Smith" Then
nr = w1.Cells(Rows.Count, "AD").End(xlUp).Row + 1
w1.Cells(nr, 30).Resize(, 23).Value = .Cells(c.Row, 1).Resize(, 23).Value
End If
Next c
End With
Application.ScreenUpdating = True
End Sub



Also note that my sheet 1 = w1 = "Score Card" *this is where I want the data to be pasted (range AD2:AZ2 and below)
sheet 2 = w2 = "Sales by Country"

want to copy All data in range B -> X on Sales by Country is column B has Joe Smith.

 

[Peter_SSs]

Welcome to the MrExcel board!

As a matter of interest, why do you rule out AutoFilter? Is it an assignment requirement?
What about Advanced Filter if that turns out to be more efficient than looping?

First however, your descriptions and screen shots seem inconsistent. For example ..
You say you have 23 columns (B:X) but you also say you want rows where Joe Smith is in column B. That would make Joe Smith in your first column, but your image in post #1 has Joe Smith in the second column.
So which column is the first column to be copied to the other sheet and which column is "Responsible Party" in?

Anyway, for this layout:

Excel Workbook
	A	B	C	D	E	F	G
1		Sales Office	Responsible Party	Company ID	Company Name	AUM (MM)
2		Boston	Joe Smith	12	Google	5
3		Boston	Joe Smith	13	BlackRock	10
4		Boston	Joe Smith	15	GE	52
5		Boston	Dan Washington	78	StateStreet	90
6		Boston	George Bard	92	BNY	100
7
Sales by Country

And this result:

Excel Workbook
	AD	AE	AF	AG	AH
1	Sales Office	Responsible Party	Company ID	Company Name	AUM (MM)
2	Boston	Joe Smith	12	Google	5
3	Boston	Joe Smith	13	BlackRock	10
4	Boston	Joe Smith	15	GE	52
5
Score Card

Try this code:

Sub FilterCopy()
  With Sheets("Sales by Country")
    .Range("Z2").Formula = "=C2 = ""Joe Smith"""
    Intersect(.UsedRange, .Columns("B:X")).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), _
        CopyToRange:=Sheets("Score Card").Range("AD1"), Unique:=False
    .Range("Z2").ClearContents
  End With
End Sub

 

[hiker95]

amorse2,

Unfortunately this did not work. I had to change a few things based on WHERE I want the data to be placed - and therefore that could have caused some issues.

In the future when asking for help, you should display the actual raw data worksheets, before, and, after. This way we can usually solve a request on the first go.

In order to continue I will have to see your actual workbook/worksheets:

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.


If you are not able to provide the above, then:

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.

 

[amorse2]

I actually do think I can use a filter to do this. And let me clarify what I am dealing with. "Sales by Country" has data from A - X. I want to filter column B based on the name of the Relationship manager that is in column D2 on the "Score Card" (another worksheet). This is what I have so far, but it isn't working.
Sub FilterCopy()

'Active sheet will always be the score card in which you are on
Dim rCrit1 As Range, rRng1 As Range, rRng2 As Range
Set rCrit1 = ActiveSheet.Range("Q4")
Set rRng1 = Sheets("Sales by Country").Range("A2:X2")
Set rRng2 = Sheets("Sales by Country").Range("A3:X500000")
'Clear area on Score Card
Sheets("Score Card").Select
Range("AD2:BA2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'Clear filter on Sales by Country
Worksheets("Sales by Country").AutoFilterMode = False
'Filter Data for Just SRM
With rRng1
.AutoFilter field:=2, Criteria1:=rCrit1.Value
' need to copy this data and then paste it - but this isn't filtering correctly.
End With

End Sub

 

[Peter_SSs]

Your descriptions are still inconsistent. This time you tell us that you want to filter on the Relationship manager that is in D2 on 'Score Card'. However, when you actually filter you are using rCrit1 which is Q4, not D2.

It also seems that you now have 24 columns rather than 23?

In any case, did you actually try my code?

Taking some more guesses from the further information provided, try this in a copy of your workbook.
I've assumed that the value to filter on is in D2 of 'Score Card' but if it is Q4, change the cell address in the commented line.
Since you will be trying this in a copy of your workbook, try it unaltered to start with to see if it is close to what you want. Then modify if changes are required. Prove the concept first.

Sub FilterCopy()
  Sheets("Score Card").Columns("AD:BA").ClearContents
  With Sheets("Sales by Country")
    .Range("Z2").Formula = "=C2='Score Card'!D2" 'or is it Q4?
    .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), _
        CopyToRange:=Sheets("Score Card").Range("AD1"), Unique:=False
    .Range("Z2").ClearContents
  End With
End Sub

Finally, when posting code, please use Code Tags (see my signature block) as reading/debugging unindented code is much more difficult.