Excel Sort By Numbers Macro - sorting

Question

I use a macro to delete rows which doesnt containing numbers for my report.
This macro find critical path numbers and split them. In a1 column it delete the numbers which doesnt in the list.
This macro works fine. Beside that i want to sort a1 column by critical path number orders.
In this link I added what i want and my report file. There is a critical path text at the bottom in report file. When i click Düzenle macro delete rows but not sort by critical path number orders.
Thanks for your helps!

Answer 1

I do not like performing complex changes and deleting rows at the same time. If anything goes wrong, you have to restore the worksheet. I have introduced a new worksheet "Critical Path" and have copied to it everything required from worksheet "Revit KBK Sonuç" in the desired sequence.
I have described what I am doing and why within the macro. I hope it is all clear but ask if necessary.
Option Explicit
Sub ertert()
' I avoid literals within the code if I think those literals may change
' over time and/or if I think a name would make the code clearer.
Const ColLast As Long = 10
Const ColShtHdrLast As Long = 2
Const TableHdr1 As String = "Total Pressure Loss Calculations by Sections"
Dim ColCrnt As Long
Dim Section() As String
Dim CriticalPath As String
Dim InxSect As Long
Dim Rng As Range
Dim RowDestNext As Long
Dim RowSrcLast As Long
Dim RowTableHdr1 As Long
Dim wshtDest As Worksheet
Dim wshtSrc As Worksheet
Set wshtSrc = Worksheets("Revit KBK Sonuç")
Set wshtDest = Worksheets("Critical Path")
With wshtDest
.Cells.EntireRow.Delete
End With
' I only work on the ActiveWorksheet if the user is to select the
' target worksheet in this way. Code is easier to understand if
' With statements are used.
With wshtSrc
' Copy column widths
For ColCrnt = 1 To ColLast
wshtDest.Columns(ColCrnt).ColumnWidth = .Columns(ColCrnt).ColumnWidth
Next
' I avoid stringing commands together. The resultant code may be
' marginally faster but it takes longer to write and much longer
' to decipher when you return to the macro in 12 months.
' Extract critial path string and convert to array of Section numbers
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
CriticalPath = .Cells(RowSrcLast, "A").Value
' Extract text before trailing total pressure loss
CriticalPath = Split(CriticalPath, ";")(0)
' Discard introductory text and trim spaces
CriticalPath = Trim(Split(CriticalPath, ":")(1))
Section = Split(CriticalPath, "-")
Set Rng = .Cells.Find(What:=TableHdr1)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row containing """ & _
TableHdr1 & """", vbOKOnly)
Exit Sub
End If
RowTableHdr1 = Rng.Row
' Copy header section of worksheet without buttons
.Range(.Cells(1, 1), .Cells(RowTableHdr1 - 1, ColShtHdrLast)).Copy _
Destination:=wshtDest.Cells(1, 1)
' Copy table header
.Range(.Cells(RowTableHdr1, 1), .Cells(RowTableHdr1 + 1, ColLast)).Copy _
Destination:=wshtDest.Cells(RowTableHdr1, 1)
RowDestNext = RowTableHdr1 + 2
' Copy rows for each section in critical path to destination worksheet
For InxSect = 0 To UBound(Section)
Set Rng = .Columns("A:A").Find(What:=Section(InxSect), LookAt:=xlWhole)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row(s) for Section" & _
Section(InxSect), vbOKOnly)
Else
Set Rng = Rng.MergeArea ' Expand to include all rows for section
' Copy all rows for section
Rng.EntireRow.Copy Destination:=wshtDest.Cells(RowDestNext, 1)
' Step output row number
RowDestNext = RowDestNext + Rng.Rows.Count
End If
Next
' Copy critical path row
.Rows(RowSrcLast).EntireRow.Copy Destination:=wshtDest.Cells(RowDestNext, 1)
RowDestNext = RowDestNext + 1
End With
' Add border at bottom of output table
With wshtDest
With .Range(.Cells(RowDestNext, 1), _
.Cells(RowDestNext, ColLast)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 16
End With
End With
End Sub
New version of macro in response to request
Because the sections have different numbers of rows, no in situ sort is possible.
Version 1 solved this problem by copying required rows to a different worksheet. Version 2 solves this problem by copying them to a workarea below the original table but within the same worksheet. That is, a new table is built beneath the old.
Once the new table is complete, the old table is deleted to move the new table into the correct position.
Sub ertert()
Const ColLast As Long = 10
Const ColShtHdrLast As Long = 2
Const TableHdr1 As String = "Total Pressure Loss Calculations by Sections"
Dim ColCrnt As Long
Dim Section() As String
Dim CriticalPath As String
Dim InxSect As Long
Dim Rng As Range
Dim RowDestNext As Long
Dim RowDestStart As Long
Dim RowSrcLast As Long
Dim RowTableHdr1 As Long
Dim wsht As Worksheet
Set wsht = ActiveSheet
With wsht
' Extract critial path string and convert to array of Section numbers
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
CriticalPath = .Cells(RowSrcLast, "A").Value
' Extract text before trailing total pressure loss
CriticalPath = Split(CriticalPath, ";")(0)
' Discard introductory text and trim spaces
CriticalPath = Trim(Split(CriticalPath, ":")(1))
Section = Split(CriticalPath, "-")
Set Rng = .Cells.Find(What:=TableHdr1)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row containing """ & _
TableHdr1 & """", vbOKOnly)
Exit Sub
End If
RowTableHdr1 = Rng.Row
' Because there is no fixed number of rows per section no in-situ sort is
' practical. Instead copy required rows in required section to destination
' area below existing area.
RowDestStart = RowSrcLast + 2
RowDestNext = RowDestStart
' Copy rows for each section in critical path to destination area
For InxSect = 0 To UBound(Section)
Set Rng = .Columns("A:A").Find(What:=Section(InxSect), LookAt:=xlWhole)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row(s) for Section" & _
Section(InxSect), vbOKOnly)
Else
Set Rng = Rng.MergeArea ' Expand to include all rows for section
' Copy all rows for section
Rng.EntireRow.Copy Destination:=.Cells(RowDestNext, 1)
' Step output row number
RowDestNext = RowDestNext + Rng.Rows.Count
End If
Next
' Copy critical path row
.Rows(RowSrcLast).EntireRow.Copy Destination:=.Cells(RowDestNext, 1)
RowDestNext = RowDestNext + 1
' Add border at bottom of output table
With .Range(.Cells(RowDestNext, 1), _
.Cells(RowDestNext, ColLast)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 16
End With
' Now have new table on rows RowDestStart to RowDestNext-1.
' Delete rows RowTableHdr1+2 to RowDestStart-1 (old table) to
' move new table into desired position.
.Rows(RowTableHdr1 + 2 & ":" & RowDestStart - 1).EntireRow.Delete
End With
End Sub