Gyorsabb futást eredményez az újabb makró, és csak a két lap nevét kell módosítani, meg esetleg az 5000 sort.

Sub Rendez()
Dim sor As Long, usor As Long, oszlop As Integer
Dim WS As Worksheet, WSF As Worksheet
Application.ScreenUpdating = False

Set WS = Sheets("Munka3") '***************
Set WSF = Sheets("Felvitel") '***************
usor = WSF.Range("A" & Rows.Count).End(xlUp).Row

WS.Select
oszlop = Range("XFD1").End(xlToLeft).Column

'Előző cella-egyesítések megszüntetése
Columns(1).MergeCells = False

'Előző adatok törlése
Rows("2:5000").Delete '***************

'Adatok a Felvitel lapról a Munka3-ra
WSF.Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Copy WS.Range("A2")

WS.Select

'Rendezés
Range(Cells(1, 1), Cells(usor, oszlop)).Select
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A" & usor) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveSheet.Sort.SortFields.Add Key:=Range("C2:C" & usor) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A1:C" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Cellaegyesítés az A oszlopban
For sor = usor To 2 Step -1
If Cells(sor, 1) = Cells(sor - 1, 1) Then
Cells(sor - 1, 1) = ""
Range(Cells(sor - 1, 1), Cells(sor, 1)).MergeCells = True
End If
Next

'Keret
Range(Cells(1, 1), Cells(usor, oszlop)).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlThin
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideHorizontal).Weight = xlThin

Application.ScreenUpdating = False
End Sub

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.