vba - copying a row based on contents of a cell

**mattbloke** · 02-04-2011, 04:18 PM

Hi guys, Your anticipated help hugely appreciated...
OK, I have a spreadsheet that tracks actions from a meeting in Sheet1. I have written a macro to create a new sheet listing the actions for each person - separated out into one sheet per person. The person is listed in Sheet1 in column G by their initials. For example, MT had 4 actions from the meeting and AL had 2 actions. Therefore MT has 4 lines of data (containing details of the action etc) and AL 2 lines. When i run my macro it will copy the 4 rows for MT, create a new worksheet called MT and then paste those rows into that worksheet. It will do the same for AL. This all works fantastic.

HOWEVER, i have one issue that is bothering me and i am having trouble with. Sometimes an action is allocated to 2 people. Say 1 action was allocated to MT and AL. This would be represented in column G by MT,AL simply separated by a comma. There could be any number of people. Using my macro this creates a new sheet MT, AL however what i would like is for the row to be copied to the MT sheet AND to the AL sheet with the appropriate initials in the G column for each sheet (and there would then be no MT,AL sheet). So really the question is what code do i put in before the sheets are split to copy that row (or any of the rows) that have more than one actionee and paste it for each person then deleting the original row.

Hope this is enough info.

The code is as follows:

Sub split_sheets_andsave()
Dim g As String



Application.ScreenUpdating = False

Worksheets("data").Visible = True
'selects raw data, copies it and pastes into data sheet so that raw data remains intact
Sheets("sheet1").Select
Cells.Select
    Selection.Copy
    Sheets("Data").Select
    Cells.Select
     ActiveSheet.Paste
  
  'sorts the data
    Columns("A:J").Select
     ActiveWorkbook.Worksheets("data").SORT.SortFields.Clear
    ActiveWorkbook.Worksheets("data").SORT.SortFields.Add Key:=Range("G2:G500") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("data").SORT.SortFields.Add Key:=Range("I2:I500") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("data").SORT.SortFields.Add Key:=Range("H2:H500") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("data").SORT
        .SetRange Range("A1:J500")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


'selects first cell with person initials
Range("G2").Select
'Parent loop ends with blank cell
Do Until ActiveCell.Value = ""

g = ActiveCell.Value
sp = ActiveCell.Address

'child loop switches with change in person initials
Do Until ActiveCell.Value <> Range("G2")
'selects last row for that person
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
en = ActiveCell.Address

'selects range for one person and cuts

Range(sp, en).EntireRow.Select
Selection.EntireRow.Cut
Sheets.Add.Name = g
Range("A1").Select
ActiveSheet.Paste
'deletes cells up
Sheets("Data").Select
Selection.Delete Shift:=xlUp
Range("G2").Select
Loop

'adds title row

Dim ws As Worksheet

  
    For Each ws In Worksheets
         If ws.Name = "data" Or ws.Name = "sheet1" Then
         Else
            ws.Select
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
        End If
    Next ws
    
   
Sheets("data").Select
   Rows("1:1").Select
 Selection.Copy

For Each ws In Worksheets
         If ws.Name = "data" Or ws.Name = "sheet1" Then
         Else
            ws.Select
            Rows("1:1").Select
            ActiveSheet.Paste
        End If
    Next ws

  Sheets("sheet1").Select
  Range("a1").Select
  
Worksheets("data").Visible = False

End Sub