Move records to different sheet based on criteria

[oxygn]

Hi guys,

I have a sheet with following data:

Item name Sheet Subject 1 1 Subject 2 2 Subject 3 3 Subject 4 4 Subject 5 1,2,3 Subject 6 1,4 Subject 7 4 Subject 8 1,3,4 Subject 9 2,3 Subject 10 3 Subject 11 2 Subject 12 1 Subject 13 1 Subject 14 1 <colgroup><col><col></colgroup><tbody> </tbody>
Column A lists all the courses, column b lists the sheets a course needs to go to. The output sheets are named Course 1.... 4 So a sample output for Course 1 (sheet) will look like: Course Subject 1 Subject 5 Subject 6 Subject 8 Subject 12 Subject 13 Subject 14 NOTE: a. all course graduation requirements, documenting course details and terminal objectives; b. all instructor course packages, including all course syllabi, Training Materials, Training aids and instructors notes and guides; c. all Training delivery plans; d. all manufacturers’ handbooks used in the delivery of Training; e. all student study guides and workbooks; f. all Training progress test and graduation specifications; and g. all Training evaluation requirements and requirements for testing student achievement <colgroup><col><col span="12"></colgroup><tbody> </tbody>
Please note that notes section must not be over written. I think I can move it one sheet, but I cannot think of a way to identify all the sheets listed in the cell. Here is a link to excel workbook:
Droplr • Temp Sheet.xlsm Thanks all, Cheers Kunal

<colgroup><col><col></colgroup><tbody>
</tbody>

 

[L. Howard]

Hi Kunal,

I have a sorta clunky vba solution if you are willing.

Requires three named ranges and two helper columns on the List sheet.

Want to give it a go?

Regards,
Howard

 

[oxygn]

Sure, please share

 

[L. Howard]

On your List sheet in the Sheet column you have some cells with multiple sheets, 1, 2, 3.
In those rows move the 2 to the next column and the 3 to the next and the same for the other few that have multiple sheet numbers. So that you have three columns with single digits and many blanks in the second and third.
Assuming the column labeled Sheets is col B select as many cell in that column as needed to cover the entries and name it ColB, select the same number of cell in C and name it ColC and same with col D. Columns C and D have just a few entries as you see.

Paste this code in the List sheet vba module and run it.

Option Explicit
Sub DataA()
Dim i As Variant
Dim ColB As Range
Dim ColC As Range
Dim ColD As Range
Dim c As Range
Application.ScreenUpdating = False
  For Each c In Range("ColB")
    If c.Value = 1 Then
      c.Offset(, -1).Copy
      Sheets("Course 1").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 2 Then
      c.Offset(, -1).Copy
      Sheets("Course 2").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 3 Then
      c.Offset(, -1).Copy
      Sheets("Course 3").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 4 Then
      c.Offset(, -1).Copy
      Sheets("Course 4").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    
  Next
  
  For Each c In Range("ColC")
    If c.Value = 1 Then
      c.Offset(, -2).Copy
      Sheets("Course 1").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 2 Then
      c.Offset(, -2).Copy
      Sheets("Course 2").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 3 Then
      c.Offset(, -2).Copy
      Sheets("Course 3").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 4 Then
      c.Offset(, -2).Copy
      Sheets("Course 4").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
  Next
  
  For Each c In Range("ColD")
    If c.Value = 1 Then
      c.Offset(, -3).Copy
      Sheets("Course 1").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 2 Then
      c.Offset(, -3).Copy
      Sheets("Sheet2").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 3 Then
      c.Offset(, -3).Copy
      Sheets("Course 3").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
    If c.Value = 4 Then
      c.Offset(, -3).Copy
      Sheets("Course 4").Range("A20").End(xlUp) _
         .Offset(1, 0).PasteSpecial
    End If
    
  Next
  
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

Regards,
Howard

 

[oxygn]

Thanks Howard, that worked. I made a slight modification to suit my needs.

Cheers,
K