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

[fairchance]

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.

 

[My Aswer Is This]

What is ID??
If ID column contains double IDs
Are you referring to column ID?
And if so what is double IDs?

 

[fairchance]

Id is a patient id. If a patient refers to more than one person then his ID will be repeat two times. If he refer three person then his ID will repeat three time alongside all record of referred person. I hope it is clarified now

 

[hiker95]

fairchance,

There are no duplicate ID's in column A, in worksheet Raw Data?????

For your request to work you will have to have some duplicate ID's.

Please post another workbook that contains duplicate ID's.

 

[My Aswer Is This]

Mistake.

 

[fairchance]

Sorry for that. Now please check the workbook

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

 

[fairchance]

No Expert available at this site? I need it on rush basis. Please solve my problem

 

[hiker95]

fairchance,

Thanks for the new workbook.

Here is a macro solution for you to consider, that will adjust to the varying number of raw data rows, and, columns.

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 CopyDupes()
' hiker95, 07/04/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
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")
With wr
  .Activate
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  .Range(.Cells(2, 1), .Cells(lr, lc)).Sort key1:=.Range("A2"), order1:=1
  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
  .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 CopyDupes macro.

 

[fairchance]

Dear Sir,

I have done all steps but found error runtime error '9' subscript out of range output attached

https://www.dropbox.com/s/wfa3gs0pm0elwtz/Referral Program Tracking.xlsm?dl=0

Kindly rectify.

Regards

Shehbaz H.

 

[fairchance]

Sorry. I have corrected the error as the sheet names were misspelled in code. Now it is working with few violations. When i re-run macro the results are adding in all six rows. All sheets except raw_data may be clear at the time of running of macro each time. Please improve the code

Regards

Shehbaz H.