How to merge rows that have similar location names

Hi All,

Please help me with this.

I have data of location & respective employee names in details sheet starting from row 6 till depends on day to day basis.
On clicking submit button, it should first sort by locations and then merge all the locations that are similar.
In short I need the final result as shown in sheet2,
but note: result should be in displayed details sheet only. That is merging & final output should be in details sheet only.
I have created Sheet2 just for your reference.

Kindly provide a macro code for this.

Try this:-
NB:- Generally, Merged cells and VB do not tend to go well together !!!!

Sub MG09Oct56
Dim Rng         As Range
Dim Dn          As Range
Dim Q           As Variant
Dim c           As Long
Dim Dic         As Object
Dim K           As Variant
Set Rng = Range(Range("A7"), Range("A" & Rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        Set Dic = CreateObject("scripting.dictionary")
            Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic.Exists(Dn.Value) Then
        ray(1, 1) = Dn: ray(1, 2) = Dn.Offset(, 1)
        Dic.Add Dn.Value, Array(ray, 1)
    Else
        Q = Dic.Item(Dn.Value)
        Q(1) = Q(1) + 1
        Q(0)(Q(1), 2) = Dn.Offset(, 1)
        Dic.Item(Dn.Value) = Q
    End If
Next

c = 7
For Each K In Dic.keys
    With Sheets("Sheet2").Range("A" & c)
        .Offset(-1).Resize(, 2) = Array("Location", "Sold By")
        With .Resize(Dic.Item(K)(1))
            .MergeCells = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        .Resize(Dic.Item(K)(1), 2) = Dic.Item(K)(0)
        c = c + Dic.Item(K)(1)
    End With
Next K
Sheets("Sheet2").Range("A:B").Columns.AutoFit
End Sub

Regards Mick

Hi Mick...
Your code still has some issues, when I click on submit sold on is getting repeated in sheet2

Hi Mick...
Your code still has some issues, when I click on submit "sold on" is getting repeated in sheet2 and also repeatative employee names should not be shown. What I mean is in the attached file
"Justin Miles" is working in same location but his name is listed twice on clicking submit his name should reflect only once and qty, cost values should be summed and displayed in final sheet. I have updated the macro code in excel & attached it for your reference.

please advise.

Can you show an example of the "Summed" values :- "Qty" ,"Cost" and "MTD Costs".
I'm not sure if they should be based on, "Person" or "Location".

If not solved !! , Try this:-

Sub MG09Oct34
Dim Dn              As Range
Dim temp            As Integer
Dim Rng             As Range
Dim nRng            As Range
Dim Dic             As Object
Dim k               As Variant
Dim p               As Variant
Dim c               As Long
 
Sheets("Sheet2").Columns("A:A").MergeCells = False
With Sheets("Details")
   Set Rng = .Range(.Range("A7"), .Range("A" & Rows.Count).End(xlUp))
End With
      Set Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMode = 1
   For Each Dn In Rng
            If Not Dic.exists(Dn.Value) Then
                Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            End If
        
        If Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) Then
                 Dic(Dn.Value).Add (Dn.Offset(, 1).Value), Dn
        Else
                Set Dic(Dn.Value).Item(Dn.Offset(, 1).Value) = Union(Dic(Dn.Value).Item(Dn.Offset(, 1).Value), Dn)
        End If
    Next Dn
   
   
   c = 7
 Sheets("Sheet2").Range("A6").Resize(, 5).Value = Array("Location", "Sold By", "Sum of Qty", "Sum of Cost", "Sum of MTD Cost")
  
For Each k In Dic.Keys
        temp = c
With Sheets("Sheet2")
        
        .Cells(c, "A") = k
            For Each p In Dic(k) 
                .Cells(c, "B") = p
                .Cells(c, "C") = Application.Sum(Dic(k).Item(p).Offset(, 2))
                .Cells(c, "D") = Application.Sum(Dic(k).Item(p).Offset(, 3))
                .Cells(c, "E") = Application.Sum(Dic(k).Item(p).Offset(, 4))
                c = c + 1
           Next p

     With .Range("A" & temp).Resize(c - temp)
            .MergeCells = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
      End With
End With
    
Next k
MsgBox "Run"
End Sub

Regards Mick