Copy of data from one sheet to other sheets based on criteria

F

fairchance

Board Regular
Joined
Jan 4, 2015
Messages
110
Dear Sir,

I have spreadsheet with column ID. I want to copy data from Raw data sheet to other six sheet on the following criteria:

1.If ID is single then these records may copied to 1 Referral
2.If ID column contains double IDs then these rows may be copied to 2 Referral sheet
3.IF ID.....................3 same values ............................................3 Referral sheet
4.............................................................................................4 Referral Sheet
5.............................................................................................5 Referral Sheet
6. If ID column contains 6 or more than six same values then............6 Referral Sheet

My worksheet is attached:

https://www.dropbox.com/s/qfh1v4sialdl69i/Referral Program Tracking.xlsx?dl=0

Kindly solve my problem and return the same after solution.

Regards

Shehbaz H.
 
Sort by date Sort by votes
Dear Sir,

Hi

I would like to have the same work with different column "Referred By", If column K is an exact match, it will pull the row into the referral sheets. The number of matches will determine what sheet it goes into. I want to see how many times the referred by person has referred patients. Can you do it sir?

Kind Regards
Shehbaz
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
fairchance said:
Dear Sir,

Hi

I would like to have the same work with different column "Referred By", If column K is an exact match, it will pull the row into the referral sheets. The number of matches will determine what sheet it goes into. I want to see how many times the referred by person has referred patients. Can you do it sir?

Kind Regards
Shehbaz
Click to expand...

fairchance,

Here is a new macro for you to consider that will return the above information with column A cells in each worksheet with a YELLOW interior color.

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).

Code: 
Sub CopyDupesV4()
' hiker95, 07/07/2015, ME865799
Dim wr As Worksheet, w1 As Worksheet, w2 As Worksheet, w3 As Worksheet
Dim w4 As Worksheet, w5 As Worksheet, w6 As Worksheet
Dim a As Variant, r As Long, lr As Long, lc As Long, n As Long, nr As Long, lr2 As Long
Application.ScreenUpdating = False
Set wr = Sheets("Raw_Data")
Set w1 = Sheets("1_Referral")
Set w2 = Sheets("2_Referral")
Set w3 = Sheets("3_Referral")
Set w4 = Sheets("4_Referral")
Set w5 = Sheets("5_Referral")
Set w6 = Sheets("6_Referral")
w1.UsedRange.Clear
w2.UsedRange.Clear
w3.UsedRange.Clear
w4.UsedRange.Clear
w5.UsedRange.Clear
w6.UsedRange.Clear
With wr
  .Activate
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  .Range(.Cells(1, 1), .Cells(1, lc)).Copy w1.Cells(1, 1)
  .Range(.Cells(1, 1), .Cells(1, lc)).Copy w2.Cells(1, 1)
  .Range(.Cells(1, 1), .Cells(1, lc)).Copy w3.Cells(1, 1)
  .Range(.Cells(1, 1), .Cells(1, lc)).Copy w4.Cells(1, 1)
  .Range(.Cells(1, 1), .Cells(1, lc)).Copy w5.Cells(1, 1)
  .Range(.Cells(1, 1), .Cells(1, lc)).Copy w6.Cells(1, 1)
  Application.CutCopyMode = False
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  .Range(.Cells(2, 1), .Cells(lr, lc)).Sort key1:=.Range("A2"), order1:=1, key2:=.Range("I2"), order2:=2
  For r = 2 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n = 1 Then
      .Range(.Cells(1, 1), .Cells(1, lc)).Copy w1.Cells(1, 1)
      nr = w1.Cells(w1.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r, lc)).Copy w1.Cells(nr, 1)
      Application.CutCopyMode = False
    ElseIf n = 2 Then
      .Range(.Cells(1, 1), .Cells(1, lc)).Copy w2.Cells(1, 1)
      nr = w2.Cells(w2.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w2.Cells(nr, 1)
      Application.CutCopyMode = False
    ElseIf n = 3 Then
      .Range(.Cells(1, 1), .Cells(1, lc)).Copy w3.Cells(1, 1)
      nr = w3.Cells(w3.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w3.Cells(nr, 1)
      Application.CutCopyMode = False
    ElseIf n = 4 Then
      .Range(.Cells(1, 1), .Cells(1, lc)).Copy w4.Cells(1, 1)
      nr = w4.Cells(w4.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w4.Cells(nr, 1)
      Application.CutCopyMode = False
    ElseIf n = 5 Then
      .Range(.Cells(1, 1), .Cells(1, lc)).Copy w5.Cells(1, 1)
      nr = w5.Cells(w5.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w5.Cells(nr, 1)
      Application.CutCopyMode = False
    ElseIf n > 5 Then
      .Range(.Cells(1, 1), .Cells(1, lc)).Copy w6.Cells(1, 1)
      nr = w6.Cells(w6.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w6.Cells(nr, 1)
      Application.CutCopyMode = False
    End If
    r = r + n - 1
  Next r
  '***** new section for REFERREDBY, column K = 11
  .Range(.Cells(2, 1), .Cells(lr, lc)).Sort key1:=.Range("K2"), order1:=2
  lr2 = .Cells(Rows.Count, "K").End(xlUp).Row
  .Range(.Cells(2, 1), .Cells(lr2, lc)).Sort key1:=.Range("K2"), order1:=1
  For r = 2 To lr2
    n = Application.CountIf(.Columns(11), .Cells(r, 11).Value)
    If n = 1 Then
      nr = w1.Cells(w1.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r, lc)).Copy w1.Cells(nr, 1)
      Application.CutCopyMode = False
      w1.Cells(nr, 1).Resize(n).Interior.Color = vbYellow
    ElseIf n = 2 Then
      nr = w2.Cells(w2.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w2.Cells(nr, 1)
      Application.CutCopyMode = False
      w2.Cells(nr, 1).Resize(n).Interior.Color = vbYellow
    ElseIf n = 3 Then
      nr = w3.Cells(w3.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w3.Cells(nr, 1)
      Application.CutCopyMode = False
      w3.Cells(nr, 1).Resize(n).Interior.Color = vbYellow
    ElseIf n = 4 Then
      nr = w4.Cells(w4.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w4.Cells(nr, 1)
      Application.CutCopyMode = False
      w4.Cells(nr, 1).Resize(n).Interior.Color = vbYellow
    ElseIf n = 5 Then
      nr = w5.Cells(w5.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w5.Cells(nr, 1)
      Application.CutCopyMode = False
      w5.Cells(nr, 1).Resize(n).Interior.Color = vbYellow
    ElseIf n > 5 Then
      nr = w6.Cells(w6.Rows.Count, "A").End(xlUp).Row + 1
      .Range(.Cells(r, 1), .Cells(r + n - 1, lc)).Copy w6.Cells(nr, 1)
      Application.CutCopyMode = False
      w6.Cells(nr, 1).Resize(n).Interior.Color = vbYellow
    End If
    r = r + n - 1
  Next r
  '***** write the a array back to its starting point
  .Range(.Cells(1, 1), .Cells(lr, lc)) = a
  Erase a
End With
w1.Columns(1).Resize(, lc).AutoFit
w2.Columns(1).Resize(, lc).AutoFit
w3.Columns(1).Resize(, lc).AutoFit
w4.Columns(1).Resize(, lc).AutoFit
w5.Columns(1).Resize(, lc).AutoFit
w6.Columns(1).Resize(, lc).AutoFit
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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the CopyDupesV4 macro.
 
Upvote 0
fairchance,

I see that in your new workbook, worksheet Raw_Data is filtered. We have not seen this before.

So that I can get it right on the next try:

Please post another workbook on BOX, containing worksheet Raw_Data, and, what the results of worksheet 1_Referral should look like (manually formatted by you)?
 
Last edited:
Upvote 0
Sir, No need for filter. We can remove filter and it is the fresh file before implementation of any macro. Waiting for your solutions Hiker95.

Regards

Shehbaz H
 
Upvote 0
Sir, Currently there may be all unique rows we can change data in required column for testing purpose. Regards
 
Upvote 0
fairchance,

So that I can get it right on the next try:

Please post another workbook on BOX, containing worksheet Raw_Data, and, what the results of worksheet 1_Referral should look like (manually formatted by you for the results that you are looking for).
 
Upvote 0
fairchance said:
Dear Sir,

Sorry for non updating the workbook. However, it has been now updated. Six sheet tabs are available with some duplicate records of column K "Referred By". Kindly look into it. Regards

Shehbaz H.
https://www.dropbox.com/s/qfh1v4sialdl69i/Referral Program Tracking.xlsx?dl=0
Click to expand...

This workbook does not have Six sheet tabs are available with some duplicate records of column K "Referred By".

If you are not able to supply any of the six sheet tabs, 1_Referral, thru, 6_Referral, with the raw data from worksheet Raw_Data from my macro CopyDupesV3, and, the NEW information from column REFERREDBY, below the results from macro CopyDupesV3, manually formatted by you for the results you are looking for, 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.
 
Upvote 0
fairchance,

Did you even try my CopyDupesV4 macro?

It copies the original required raw data from worksheet Raw_Data into worksheets 1_Referral, thru, 6_Referral.

Then, macro CopyDupesV4 copies the information from column REFERREDBY, per your request, into worksheets 1_Referral, thru, 6_Referral, and, these new rows of information, their column A cells, have a YELLOW background color, to help them stand out.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question
How to compare data between two sheets, extract the changed lines and copy into another sheet
Replies
7
Views
328
frostworks
F
I
  • Question
Find duplicate column values across multiple workbooks, and get data row and set row data to new sheet
Replies
2
Views
249
itomedina25
I
S
  • Question
Copy rows from multiple worksheets into multiple worksheets in another workbook based on criteria
Replies
1
Views
152
eiloken
E
H
  • Solved
Link data in sheet to individual - VBA
Replies
9
Views
376
helplessnoobatexcel
H
K
  • Question
Copy selected rows from txt file and paste to excel based on one criteria applied on one column
Replies
5
Views
237
dmt32
D

Forum statistics

Threads
1,216,520
Messages
6,131,135
Members
449,626
Latest member
Stormythebandit

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