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.

 

[hiker95]

fairchance,

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

The reason the original macro did not work correctly on your latest posted workbook, is because your original workbook had worksheet names like (without the _ characters):
Raw Data
1 Referral
2 Referral
3 Referral
4 Referral
5 Referral
6 Referral

Here is another macro solution for you to consider, with the corrected worksheet names:
Raw_Data
1_Referral
2_Referral
3_Referral
4_Referral
5_Referral
6_Referral

All sheets except raw_data may be clear at the time of running of macro each time.

I missed this new request - be back in a little while.

 

[fairchance]

Dear Sir (Hiker95)

I am looking for your reply with acknowledging your knowledge and experience.

Kind Regards

Shehbaz H.

 

[hiker95]

fairchance,

Here is another macro solution for you to consider.

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 CopyDupesV2()
' 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")
w1.UsedRange.ClearContents
w2.UsedRange.ClearContents
w3.UsedRange.ClearContents
w4.UsedRange.ClearContents
w5.UsedRange.ClearContents
w6.UsedRange.ClearContents
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 CopyDupesV2 macro.

 

[fairchance]

Thank You so much sir. It is working. Can the moving data may be sorted on DOSData Descending order before pasting to other sheets?

Best wishes

 

[skypickle]

Fairchance,
I hope your data is fake and not a hipaa violation.

 

[fairchance]

I extremely sorry this is only word nothing else i take my word back ok?. Please Do not create embarrassment. Regards

 

[hiker95]

Thank You so much sir. It is working.
Best wishes

fairchance,

Thanks for the feedback.

You are very welcome. Glad I could help.

Can the moving data may be sorted on DOSData Descending order before pasting to other sheets?

Be back in a little while.

 

[hiker95]

fairchance,

If I understand you correctly, see if the following macro produces the new results you are looking for: sorting column A groups ascending, column I groups descending, before the data is copied to its correct worksheet.

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 CopyDupesV3()
' hiker95, 07/05/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")
w1.UsedRange.ClearContents
w2.UsedRange.ClearContents
w3.UsedRange.ClearContents
w4.UsedRange.ClearContents
w5.UsedRange.ClearContents
w6.UsedRange.ClearContents
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, 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
  .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 CopyDupesV3 macro.

 

[fairchance]

Thank you so much sir. This is what i want. I really appreciate your work. May God bless you. Regards
Shehbaz H.

 

[hiker95]

fairchance,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.