Zusammenführen und Sortieren

Sub Zusammenschreiben()
Dim ws As Worksheet
Dim wsTotal As Worksheet
Dim lngLastCol As Long
Dim lngLastRow As Long
Dim rngTotalFound As Range
Dim lngTotalRow As Long
Dim lngCounter As Long
Dim strSearch As String
Dim sTabs As String
'Tabellen, die zusammengeführt werden sollen
sTabs = "*Tabelle2*Tabelle4*Tabelle5*"
On Error GoTo Zusammenschreiben_Error
Application.ScreenUpdating = False
Set wsTotal = Sheets("Tabelle6")
'** Clear Used-Range ohne Ünerschriftzeile   (Piet)
wsTotal.UsedRange.Offset(1, 0).Delete
For Each ws In Worksheets
If InStr(1, sTabs, "*" & ws.Name & "*", vbTextCompare) > 0 _
Then
lngTotalRow = wsTotal.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print lngTotalRow
With ws
lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A2:A" & lngLastRow).Copy Destination:=wsTotal.Range("A" & lngTotalRow) 'Spalte A  _
_
.Range("B2:J10" & lngLastRow).Copy Destination:=wsTotal.Range("G" & lngTotalRow) 'Spalten  _
_
End With
End If
Next ws
With wsTotal
lngTotalRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("B1:F1").Copy
.Range("B2:F" & lngTotalRow).PasteSpecial Paste:=xlPasteFormulas
Application.CutCopyMode = False
End With
'** Rahmen senkrecht  - neu eingefügt -  (Piet)
lngLastRow = wsTotal.Range("A1").End(xlDown).Row
With wsTotal.Range("A1:A" & lngLastRow)
.Offset(0, 0).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 5).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
'** Rahmen senkrecht  - Ende -
exit_here:
Set rngTotalFound = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
Zusammenschreiben_Error:
MsgBox "Fehler " & Err.Number & " (" & Err.Description & ") in der Prozedur Zusammenschreiben"
Resume exit_here
End Sub

Sub Schaltfläche1_Klicken()
Range("A2:O25").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub