Is there a way of speeding up these codes? It takes about 2 minutes to run this code with 6k rows.

[Coyotex3]

Sub OrderFormatting()
    Range("A1:P40000").Select
    With Selection
        .Hyperlinks.Delete
        With Selection
    .Borders.LineStyle = xlNone
            With .Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
            End With
        End With
    End With
    Range("A1:P40000").UnMerge
End Sub

Sub CopyDeleteInsertSortInsertDelete()
    Dim x   As Long, LastRow    As Long
    Dim rng As Range
    
    Range("D:E,K:O").Delete
    Columns("A:O").EntireColumn.AutoFit
    
    For Each rng In Range("D8", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
        rng.Offset(-1, -3).ReSize(rng.Count + 1, 2).FillDown
    Next rng
End Sub

Sub DeleteBlankRows()

With Range("D6:D" & Cells(Rows.Count, "B").End(xlUp).Row)
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
End With

End Sub

Sub EndFormatting()

    Rows(5).Insert

    Range("A6").CurrentRegion.Sort Range("D6"), xlAscending, Range("A6"), , xlAscending, Header:=xlYes

    Const DataCol As String = "D"
    Const StartRow = 6

    LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row

    Application.ScreenUpdating = False

    For x = LastRow To StartRow + 1 Step -1
    
    
        If Cells(x, DataCol).Value <> Cells(x - 1, DataCol) Then Range(DataCol & x & ":" & DataCol & x + 2).EntireRow.Insert
    Next

    Rows("5:5").EntireRow.Delete

    Rows("6:8").EntireRow.Delete
End Sub

Sub UsualS()
  Dim LR As Long, i As Long
  
  Application.ScreenUpdating = False
  LR = Range("A" & Rows.Count).End(xlUp).Row
  For i = LR To 1 Step -1
    If Range("A" & i) = "01" And (Range("D" & i).Value = "bronx" Or Range("D" & i).Value = "brooklyn" Or Range("D" & i).Value = "queens") Then Rows(i).Delete
  Next i
  Application.ScreenUpdating = True
End Sub

Sub RangeLabels11()
Application.ScreenUpdating = False
Dim area As Range, lngRentRow&
For Each area In Columns(1).SpecialCells(2).Areas
lngRentRow = area.Row + area.Rows.Count
With Cells(lngRentRow, 7)
.Value = "Rent"
.Font.Bold = True
.Interior.Color = 5296274
With .Offset(1)
.Value = "Cash"
.Font.Bold = True
.Interior.Color = 65535
End With
End With
Next area
Columns(7).AutoFit
Application.ScreenUpdating = True

ActiveCell.Columns("G:G").EntireColumn.EntireColumn.AutoFit
End Sub

Sub Sorting()
   Dim UsdRws As Long
   
   UsdRws = Range("A" & Rows.Count).End(xlUp).Row
   With Range("A:A").SpecialCells(xlConstants)
      With Range(.Areas(.Areas.Count - 1), Range("A" & UsdRws)).ReSize(, 9)
         .Sort .Range("A1"), xlAscending, .Range("G1"), , xlAscending, Header:=xlNo
      End With
   End With
End Sub

Sub States()
Dim States(4) As Variant
Dim i As Long

States(1) = "nc"
States(2) = "sc"
States(3) = "wa"
States(4) = "ga"

With ActiveSheet
    For i = 1 To 4
        .AutoFilterMode = False
        With Range("d1", Range("d" & Rows.Count).End(xlUp))
            .AutoFilter 1, "*" & States(i) & "*"
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete
        End With
        .AutoFilterMode = False
    Next i
End With
End Sub

Sub UsualS565()
  Dim LR As Long, i As Long
  
  Application.ScreenUpdating = False
  LR = Range("A" & Rows.Count).End(xlUp).Row
  For i = LR To 1 Step -1
    If Range("A" & i) = "01" And (Range("D" & i).Value = "bronx" Or Range("D" & i).Value = "brooklyn" Or Range("D" & i).Value = "queens") Then Rows(i).Delete
  Next i
  Application.ScreenUpdating = True
End Sub
Sub GetLastRow()
Range("A" & Rows.Count).End(xlUp).Select
 Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
End Sub

I have a code which calls all of these macros. Would be great if they could be consolidated and tweaked to make faster. Thank you.

 

[DanteAmor]

I would love to be able to keep the alphanumeric cities grouped together.

Try this:

Sub FormatData_2()
  Dim sh1 As Worksheet, sht As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, m As Long
  Dim ant As String, city As String
  
  Set sh1 = Sheets("Sheet10")
  Set sht = Sheets("Temp")
  a = sh1.Range("A8:P" & sh1.Range("F" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 9)
  
  For i = 1 To UBound(a)
    If a(i, 1) <> "" And a(i, 2) <> "" Then
      ant = a(i, 1) & "|" & a(i, 2)
    ElseIf a(i, 6) <> "" Then
      If Not (Split(ant, "|")(0) = "10" And InStr("bronx brooklyn queens", a(i, 6)) > 0) Then
        k = k + 1
        For j = 1 To 16
          Select Case j
            Case 1:       b(k, 1) = Split(ant, "|")(0): b(k, 2) = Split(ant, "|")(1)
            Case 3:       b(k, 3) = a(i, 3)
            Case 6 To 10: b(k, j - 2) = a(i, j)
            Case 16:      b(k, j - 7) = a(i, j)
          End Select
        Next
      End If
    End If
  Next

  sht.Cells.ClearContents
  sh1.Range("A5,B5,C5,F5,G5,H5,I5,J5,P5").Copy sht.Range("A5")
  sht.Range("A6").Resize(k, 9).Value = b    'Pass array to cells
  sht.Range("A5").CurrentRegion.Sort sht.Range("D6"), xlAscending, sht.Range("A6"), , xlAscending, Header:=xlYes
  sht.Range("A1:A4").Value = sh1.Range("A1:A4").Value
  Erase a, b
  a = sht.Range("A6:I" & sht.Range("A" & Rows.Count).End(3).Row + 1).Value
  ReDim b(1 To UBound(a, 1) * 4, 1 To 9)
  
  ant = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(a(1, 4), _
        "0", ""), "1", ""), "2", ""), "3", ""), "4", ""), "5", ""), "6", ""), "7", ""), "8", ""), "9", "")
  k = 0
  For i = 1 To UBound(a, 1)
    city = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(a(i, 4), _
        "0", ""), "1", ""), "2", ""), "3", ""), "4", ""), "5", ""), "6", ""), "7", ""), "8", ""), "9", "")
    If ant <> city Then
      b(k + 1, 7) = "Rent"
      b(k + 2, 7) = "Cash"
      k = k + 3
    End If
    k = k + 1
    For j = 1 To 9
      b(k, j) = a(i, j)
    Next
    ant = city
  Next
  
  sht.Range("A6").Resize(k, 9).Value = b    'Pass array to cells
  With Application.ReplaceFormat
    .Clear
    .Interior.Color = 5296274
    .Font.Bold = True
    sht.Range("G:G").Replace "Rent", "Rent", xlWhole, xlByRows, False, , False, True
    .Interior.Color = 65535
    sht.Range("G:G").Replace "Cash", "Cash", xlWhole, xlByRows, False, , False, True
    .Clear
  End With
  sht.Columns("A:I").EntireColumn.AutoFit
End Sub