Find and action Duplicate

[Lovelylou79]

Hello Excel Community,

I am stuck on the next part of a large code that splits my worksheet into various new sheets based on different variables.

The next part of my code needs to do the following;

Recognise duplicate Name in "A", i.e; Fred & Fred.
Then, create a new worksheet based on a combination of colms D and F. D is the severity of the object, either 1,2,3, or 4. F is an error msg.
All rows for Fred need to be cut and paste into a new sheet with the higher severity error msg as the lead/main. Then deleted from the original sheet.

Fred 1 101
Fred 2 93
Fred 3 167
Fred 3 167

All of these would be moved for sheet 1 to a new "101" sheet.

I have up to 57 error msg codes that may need to be split, I can have these on a hidden sheet if need be. I have a test page ready, however I am unable to attach to this query.

Any assistance is appreciated.

 

[Peter_SSs]

Happy to PM a test sheet if that would help.

Yes, you may PM me.

Please note that this breaches no. 4 of the Forum Rules.

Since this is a public forum, other members may want to get involved in the thread and have access to to available information. There are several methods available for posting sample data directly in the forum (my signature block below has a link) and failing that, a worksheet could be uploaded to a public file-share site with a link to it posted here.

 

[BrianJN1]

LovelyLou79,
I rearranged your table at comment #3 such that A is name, B is Error Codes and C is severity. I then sorted each column ascending.

With that short table under consideration I was able to develop this macro:

Sub Severe()

LR = Cells(Rows.Count, "A").End(xlUp).Row
For a = 1 To LR
Dim xName As String
    Dim xSht As Object
    
    On Error Resume Next
    xName = Range("Sheet1!B" & a).Value
     Set xSht = Sheets(xName)
      If Not xSht Is Nothing Then
        
            end if
    Sheets.Add(, Sheets(Sheets.Count)).Name = xName
        
    Sheets("Sheet1").Rows(a).Copy
    Range("A1").PasteSpecial
 Next
End Sub

At this point it was only intended to create new sheets and test copying data from Sheet1.
Unfortunately, if the macro sees a duplicate it ceases to build new Worksheets for valid names beyond where it finds the duplicate.

I realise that "Fred" for instance is therefore spread over three worksheets because I was not then ready to consider duplicates.

I've offered the above code so that you, or maybe someone else, may progress your cause at the same time as solving the issue that faced me.

I note that if I remove:
If Not xSht Is Nothing Then

end if
then a new sheet is created named Sheet (#x)

 

[Lovelylou79]

Hi Brian,

Thank you for taking the time to post your code and with all your assistance. Its a good start.
I'm going to try to keep muddling through as this thread has not been very successful. If I manage to work out a solution I will post it here.

 

[Peter_SSs]

Based on the layout and descriptions in post 3 you could try this on a copy of your workbook.
Currently the code does not delete the data from the original sheet. If you need that to actually happen, then uncomment the green line near the bottom of the code.

Sub MoveToErrorSheet()
  Dim d1 As Object, d2 As Object
  Dim a As Variant, b As Variant, aRws As Variant, bits As Variant, itm As Variant
  Dim i As Long, nc As Long, lr As Long
  
  Set d1 = CreateObject("Scripting.Dictionary")
  d1.CompareMode = 1
  Set d2 = CreateObject("Scripting.Dictionary")
  nc = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  lr = Cells(Rows.Count, 1).End(xlUp).Row
  aRws = Evaluate("row(1:" & lr & ")")
  a = Application.Index(Cells, aRws, Array(1, 4, 6)) '<- 1, 4, 6 represents columns A, D & F
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 2 To UBound(a)
    If d1.exists(a(i, 1)) Then
      bits = Split(d1(a(i, 1)))
      If Val(bits(0)) > a(i, 2) Then d1(a(i, 1)) = a(i, 2) & " " & a(i, 3)
    Else
      d1(a(i, 1)) = a(i, 2) & " " & a(i, 3)
    End If
  Next i
  For i = 2 To UBound(a)
    b(i, 1) = Split(d1(a(i, 1)))(1)
    d2(b(i, 1)) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A1").Resize(lr, nc)
    .Columns(nc).Value = b
    Application.DisplayAlerts = False
    For Each itm In d2.keys
      On Error Resume Next
      Sheets(itm).Delete
      On Error GoTo 0
      Sheets.Add(After:=ActiveSheet).Name = itm
      .AutoFilter Field:=nc, Criteria1:=itm
      .Resize(, nc - 1).Copy Destination:=Sheets(itm).Range("A1")
    Next itm
    Application.DisplayAlerts = True
    .Parent.AutoFilterMode = False
    .Columns(nc).ClearContents
'    .Offset(1).EntireRow.Delete
  End With
  Application.ScreenUpdating = True
End Sub

 

[Lovelylou79]

Peter_SS, You are officially my Hero!!

It will take me some time to break this down to try to understand exactly what is going on here, however it works perfectly! It even eliminates some of the preceding code I had.

Thank you so very much!

 

[Peter_SSs]

Peter_SS, You are officially my Hero!!

It will take me some time to break this down to try to understand exactly what is going on here, however it works perfectly! It even eliminates some of the preceding code I had.

Thank you so very much!

You are very welcome. I'm sorry it took me quite a while to get my head around the requirement.