If the final order of the data on each User is not important
Option Explicit
Sub MergeSortSchred()
Dim wsTemp As Worksheet, ws As Worksheet, wsName As Worksheet
Dim rDest As Range, rSrc As Range, rSort As Range, rRow As Range
Dim sPrevName As String
Application.ScreenUpdating = False
'add new temp
Set wsTemp = pvtAddSheet("Temp")
'merge all worksheets onto temp
For Each ws In ActiveWorkbook.Worksheets
Set rDest = wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp)
If Not ws Is wsTemp Then
Set rSrc = ws.UsedRange
Set rSrc = Intersect(rSrc, Range(ws.Rows(2), ws.Rows(Rows.Count)))
Set rDest = wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Offset(1, 0)
rSrc.Copy rDest
End If
Next
'sort temp by Balance in column 1 first
Set rSort = wsTemp.Cells(1, 1)
Set rSort = Range(rSort, wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp))
Set rSort = Intersect(rSort.EntireRow, wsTemp.UsedRange.EntireColumn)
With wsTemp.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort temp by name in column 2
Set rSort = wsTemp.Cells(1, 1)
Set rSort = Range(rSort, wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp))
Set rSort = Intersect(rSort.EntireRow, wsTemp.UsedRange.EntireColumn)
With wsTemp.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'loop down wsTemp, add sheet for new name, copy data over
sPrevName = vbNullString
For Each rRow In wsTemp.Cells(1, 1).CurrentRegion.Rows
With rRow
'some names in sampe are blank
If Len(.Cells(2).Value) = 0 Then .Cells(2).Value = "No Name"
If .Cells(2).Value <> sPrevName Then
sPrevName = .Cells(2).Value
Set wsName = pvtAddSheet(.Cells(2).Value)
wsName.Cells(1, 1).Value = "Balance"
wsName.Cells(1, 2).Value = "User"
End If
.Copy wsName.Cells(wsName.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
Next
Call pvtDeleteSheet("Temp")
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Private Sub pvtDeleteSheet(s As String)
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(s).Delete
Application.DisplayAlerts = True
On Error GoTo 0
End Sub
Private Function pvtAddSheet(s As String) As Worksheet
Call pvtDeleteSheet(s)
Worksheets.Add.Name = s
Set pvtAddSheet = ActiveSheet
End Function