VBA Macro Help: add a line in a sheet to capture duplicates in source data

[bjrein]

I'm hoping someone can assist me in writing a script which would automatically add a line in a sheet ('Sheet1') when a duplicate is identified in another sheet ('Sheet2').

To further explain, basically I have a two sheets which contains completely separate information with the exception of one column which identifies a category/group. 'Sheet1' identifies all possible categories/groups as well as a number associated with a given group on a monthly basis. 'Sheet2' identifies a person, the role or service they provide, and the group they are a part of. Previously I wrote a function to combined the names of all the people associated with a group (found in 'Sheet 2') into the individual group cell in 'Sheet1', however upon review with other stakeholders it was concluded that when a duplicate group is found on 'Sheet2' an additional group line item should be added to 'Sheet1'.

I've Provide shap-shots below to help clarify(FYI - please assume the first 'cell' is A1):

1) Below is a condensed example of the Information found in 'Sheet2'

[TABLE="class: grid, width: 528"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Role[/TD]
[TD]Group Description & Number[/TD]
[TD]Group Name[/TD]
[TD]Group #[/TD]
[/TR]
[TR]
[TD]John Smith[/TD]
[TD]PM[/TD]
[TD]1 - Corporate[/TD]
[TD]Corporate[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Jane Smith[/TD]
[TD]PE[/TD]
[TD]1 - Corporate[/TD]
[TD]Corporate[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]John Doe[/TD]
[TD]Consultant[/TD]
[TD]2 - External Resources[/TD]
[TD]External Resources[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Jane Doe[/TD]
[TD]Consultant[/TD]
[TD]2 - External Resources[/TD]
[TD]External Resources[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]

2) Below is my current view in 'Sheet1' using the combined function.

[TABLE="class: grid, width: 875"]
<colgroup><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]# - Group description[/TD]
[TD]Group Description[/TD]
[TD]Team Member[/TD]
[TD]Role[/TD]
[TD]Group[/TD]
[TD]Jan - 15[/TD]
[TD]Feb - 15[/TD]
[TD]Mar - 15[/TD]
[/TR]
[TR]
[TD]1 - Corporate[/TD]
[TD]Corporate[/TD]
[TD]John Smith, Jane Smith[/TD]
[TD]PM, PE[/TD]
[TD]1[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2 - External Resources[/TD]
[TD]External Resources[/TD]
[TD]John Doe, Jane Doe[/TD]
[TD]Consultant, Consultant[/TD]
[TD]2[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]

3) Below is an example of desired outcome once script is complete.

[TABLE="class: grid, width: 875"]
<colgroup><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]# - Group description[/TD]
[TD]Group Description[/TD]
[TD]Team Member[/TD]
[TD]Role[/TD]
[TD]Group[/TD]
[TD]Jan - 15[/TD]
[TD]Feb - 15[/TD]
[TD]Mar - 15[/TD]
[/TR]
[TR]
[TD]1 - Corporate[/TD]
[TD]Corporate[/TD]
[TD]John Smith[/TD]
[TD]PM[/TD]
[TD]1[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]1 - Corporate[/TD]
[TD]Corporate[/TD]
[TD]Jane Smith[/TD]
[TD]PE[/TD]
[TD]1[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2 - External Resources[/TD]
[TD]External Resources[/TD]
[TD]John Doe[/TD]
[TD]Consultant[/TD]
[TD]2[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2 - External Resources[/TD]
[TD]External Resources[/TD]
[TD]Jane Doe[/TD]
[TD]Consultant[/TD]
[TD]2[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]

If anyone can assist with this script it would be greatly appreciated.

 

[onlyadrafter]

Hello,

could tidy this code up further, but...

Sub ADD_ROW_FOR_DUPLICATE()
    For MY_ROWS = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Len(Range("C" & MY_ROWS).Value) - Len(Replace(Range("C" & MY_ROWS).Value, ",", "")) > 0 Then
            Rows(MY_ROWS + 1).Insert
            Rows(MY_ROWS).Copy
            Rows(MY_ROWS + 1).PasteSpecial (xlPasteAll)
            Range("C" & MY_ROWS & ":C" & MY_ROWS + 1).TextToColumns Destination:=Range("K" & MY_ROWS), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
            Range("K" & MY_ROWS).Copy Range("C" & MY_ROWS)
            Range("L" & MY_ROWS).Copy Range("C" & MY_ROWS + 1)
            Columns("K:L").ClearContents
            Range("D" & MY_ROWS & ":D" & MY_ROWS + 1).TextToColumns Destination:=Range("K" & MY_ROWS), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
            Range("K" & MY_ROWS).Copy Range("D" & MY_ROWS)
            Range("L" & MY_ROWS).Copy Range("D" & MY_ROWS + 1)
            Columns("K:L").ClearContents
        End If
        Next MY_ROWS
End Sub

this assumes columns K and L are available. Also, have only allowed for two names in each cell.

Is this any use?

 

[bjrein]

Hi OnlyaDrafter,

Thanks for the response. I've been going through your code hoping to use a similar methodology and adapt as needed but I have thus been unsuccessful thus far. I have two issues which I'm trying to solve; The first one is that "sheet2" is variable and will change on a monthly basis, the Second issue I need to address is that the number people with a given category/group is variable and can be greater than 2. I've been attempting to add in something like a countif code but thus far have been unsuccessful. Do you have any guidance?

 

[onlyadrafter]

Hello,

have created a work around the number of names being more than 2. Need more info regarding the monthly change in 'Sheet2'.

Sub ADD_ROW_FOR_DUPLICATE()
    Application.ScreenUpdating = False
    For Each cell In Range("C2:D" & Range("D" & Rows.Count).End(xlUp).Row)
        cell.Value = Replace(cell.Value, " ", "")
    Next cell
    For MY_ROWS = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        NEW_COLS = Len(Range("C" & MY_ROWS).Value) - Len(Replace(Range("C" & MY_ROWS).Value, ",", ""))
        If NEW_COLS > 0 Then
            For MY_NEW_COL = 1 To NEW_COLS
                Rows(MY_ROWS + MY_NEW_COL).Insert
                Rows(MY_ROWS).Copy
                Rows(MY_ROWS + MY_NEW_COL).PasteSpecial (xlPasteAll)
            Next MY_NEW_COL
            Range("C" & MY_ROWS & ":C" & MY_ROWS + MY_NEW_COL).TextToColumns Destination:=Range("K" & MY_ROWS), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
            For MY_NEW_COL = 1 To NEW_COLS + 1 'MY_ROWS To MY_ROWS + NEW_COLS
                Cells(MY_ROWS - 1, 10).Offset(MY_NEW_COL, MY_NEW_COL).Copy
                Cells(MY_ROWS - 1, 3).Offset(MY_NEW_COL, 0).PasteSpecial (xlPasteValues)
            Next MY_NEW_COL
            Columns("K:Z").ClearContents
            Range("D" & MY_ROWS & ":D" & MY_ROWS + MY_NEW_COL).TextToColumns Destination:=Range("K" & MY_ROWS), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
            For MY_NEW_COL = 1 To NEW_COLS + 1
                Cells(MY_ROWS - 1, 10).Offset(MY_NEW_COL, MY_NEW_COL).Copy
                Cells(MY_ROWS - 1, 4).Offset(MY_NEW_COL, 0).PasteSpecial (xlPasteValues)
            Next MY_NEW_COL
            Columns("K:Z").ClearContents
        End If
        Next MY_ROWS
        Application.ScreenUpdating = True
End Sub

Is this better?

 

[bjrein]

Thanks for the response. What I meant by the 'monthly changes in 'Sheet2' is that the person or number of people will change on a monthly basis and that information is captured in 'Sheet2': currently the macro is not incorporating 'Sheet2' and is only considering 'Sheet1' and using the ',' to separate the names.

I've been attempting to modify your code to try and incorporate 'Sheet2' but am having difficulty. My thought was to add a countif code (or something to those effect) in order to add the correct number of columns then do an Index match or something to add the names. Do you know if this is possible? or do you have any other ideas as to how to incoorparate 'Sheet2' into the macro?