Help with this custom sort and insert blank rows macro?

[Coyotex3]

Hello, so I will have a variable range like this

Automation(19128).xlsx
	A	B	C	D	E	F	G	H	I	J
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info
7	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850.00	1256987569
8	10	John	None	bronx	10/10/2020	Non-Available	1	500.00	789546521
9	15	Jack	None	bronx	9/21/2020	Non-Available	3	850.00	1256987569
10	15	Jack	None	bronx	9/21/2020	Non-Available	6	850.00	1256987569
11	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750.00	654789546
12	15	Jack	None	queens	9/21/2020	Non-Available	4	850.00	1256987569
13
Sheet1

And I will use these codes

Sub CopySort()
Range("A6").CurrentRegion.Sort Range("D6"), xlAscending, Range("A6"), , xlAscending, Header:=x
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
End Sub

To get this

Automation(19128).xlsx
	A	B	C	D	E	F	G	H	I
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info
7
8
9
10	10	John	None	bronx	10/10/2020	Non-Available	1	500.00	789546521
11	15	Jack	None	bronx	9/21/2020	Non-Available	3	850.00	1256987569
12	15	Jack	None	bronx	9/21/2020	Non-Available	6	850.00	1256987569
13
14
15
16	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750.00	654789546
17
18
19
20	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850.00	1256987569
21
22
23
24	15	Jack	None	queens	9/21/2020	Non-Available	4	850.00	1256987569
25
Sheet1

On some of my ranges column D will not be an exact match and will be something like: Bronx01, Bronx02 or Bronx04 etc. I would like for the code to keep them together and not separate them and hopefully get something like this

Automation(19128).xlsx
	A	B	C	D	E	F	G	H	I
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info
7
8
9
10	10	John	None	bronx01	10/10/2020	Non-Available	1	500.00	789546521
11	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850.00	1256987569
12	15	Jack	None	bronx12	9/21/2020	Non-Available	6	850.00	1256987569
13
14
15
16	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750.00	654789546
17
18
19
20	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850.00	1256987569
21
22
23
24	15	Jack	None	queens	9/21/2020	Non-Available	4	850.00	1256987569
25
Sheet1

And not this which is what I get when I run the code

Automation(19128).xlsx
	A	B	C	D	E	F	G	H	I
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info
7
8
9
10	10	John	None	bronx01	10/10/2020	Non-Available	1	500.00	789546521
11
12
13
14	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850.00	1256987569
15
16
17
18	15	Jack	None	bronx12	9/21/2020	Non-Available	6	850.00	1256987569
19
20
21
22	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750.00	654789546
23
24
25
26	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850.00	1256987569
27
28
29
30	15	Jack	None	queens	9/21/2020	Non-Available	4	850.00	1256987569
Sheet1

 

[BSALV]

Sub Sorteer()
     With Range("TBL_Report").ListObject                        'your list
          With .Range
               .Sort .Cells(1, 10), xlDescending, Header:=xlYes     'sort on the new column "city2"
          End With

          a = .DataBodyRange.Columns(10).Value                  'read that column "city2"
          For i = UBound(a) - 1 To 1 Step -1                    'loop from 2nd last row to row 1
               If StrComp(a(i, 1), a(i + 1, 1), vbTextCompare) <> 0 Then     'if other city2 then
                    .DataBodyRange.Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown     'insert 2 empty rows
               End If
          Next
     End With
End Sub

There is a 2nd table where you add cities that make part of a greater city, for example your Bronx01, etc.
In the column "city2" this records get the same value

report.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Report														city	city2
2	User														bronx01	bronx
3	Date:12/01														bronx02	bronx
4	Time: 12:45														bronx03	bronx
5															bronx04	bronx
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info	city2					brookyn	brooklyn
7	15	Jack	None	queens	9/21/2020	Non-Available	4	850	1256987569	queens
8										0
9										0
10	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750	654789546	brooklyn
11	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850	1256987569	brooklyn
12										0
13										0
14	10	John	None	bronx01	10/10/2020	Non-Available	1	500	789546521	bronx
15	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850	1256987569	bronx
16	15	Jack	None	bronx	9/21/2020	Non-Available	6	850	1256987569	bronx
17
18
Blad2

Cell Formulas
Range	Formula
J7:J16	J7	=IFERROR(VLOOKUP([@City],Tabel3,2,0),[@City])

 

[Coyotex3]

Sub Sorteer()
     With Range("TBL_Report").ListObject                        'your list
          With .Range
               .Sort .Cells(1, 10), xlDescending, Header:=xlYes     'sort on the new column "city2"
          End With

          a = .DataBodyRange.Columns(10).Value                  'read that column "city2"
          For i = UBound(a) - 1 To 1 Step -1                    'loop from 2nd last row to row 1
               If StrComp(a(i, 1), a(i + 1, 1), vbTextCompare) <> 0 Then     'if other city2 then
                    .DataBodyRange.Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown     'insert 2 empty rows
               End If
          Next
     End With
End Sub

There is a 2nd table where you add cities that make part of a greater city, for example your Bronx01, etc.
In the column "city2" this records get the same value

report.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Report														city	city2
2	User														bronx01	bronx
3	Date:12/01														bronx02	bronx
4	Time: 12:45														bronx03	bronx
5															bronx04	bronx
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info	city2					brookyn	brooklyn
7	15	Jack	None	queens	9/21/2020	Non-Available	4	850	1256987569	queens
8										0
9										0
10	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750	654789546	brooklyn
11	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850	1256987569	brooklyn
12										0
13										0
14	10	John	None	bronx01	10/10/2020	Non-Available	1	500	789546521	bronx
15	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850	1256987569	bronx
16	15	Jack	None	bronx	9/21/2020	Non-Available	6	850	1256987569	bronx
17
18
Blad2

Cell Formulas
Range	Formula
J7:J16	J7	=IFERROR(VLOOKUP([@City],Tabel3,2,0),[@City])

Thank you for the reply and the suggestion. The only issue is that these ranges will have more than 6k rows and many city variables. It might take a while to copy all the cities into the other table. One thing I will say is that the cities will always be separated by numbers. meaning it will always be something like bronx01 bronx10 bronx05, or brooklyn02 brooklyn10 brooklyn18, or 01manhattan02 manhattan04 etc. meaning the letters will always match, the numbers will be different.

 

[Coyotex3]

Meant to say 01manhattan 02manhattan 03manhattan etc***

 

[BSALV]

Meant to say 01manhattan 02manhattan 03manhattan etc***
in the formula of city2, make right left and left right

if the last 2 characters of the city are numeric, they are omitted, no 2nd table anymore.

Sub Sorteer()
     Dim DBR
     With Range("TBL_Report").ListObject                        'your list
          With .Range
               .Sort .Cells(1, 10), xlAscending, Header:=xlYes  'sort on the new column "city2"
          End With

          a = .DataBodyRange.Columns(10).Value                  'read that column "city2"
          For i = UBound(a) - 1 To 1 Step -1                    'loop from 2nd last row to row 1
               If StrComp(a(i, 1), a(i + 1, 1), vbTextCompare) <> 0 Then     'if other city2 then
                    .DataBodyRange.Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown     'insert 2 empty rows
               End If
          Next

          On Error Resume Next
          s = "": s = .DataBodyRange.SpecialCells(xlCellTypeBlanks).Address     'address of all the blank cells in the databodyrange
          If Len(s) > 0 Then                                    'there are blank cells
               sp = Split(s, ",")                               'split the address
               Set c = .Parent.Range(sp(UBound(sp)))            'last area = empty rows at the bottom of the list
               Set DBR = .DataBodyRange
               If c.Columns.Count = DBR.Columns.Count - 1 Then  'that area : number of columns= 1 less than databodyrange
                    If DBR.Row + DBR.Rows.Count = c.Row + c.Rows.Count Then     'last row=same as last row DBR
                         DBR.Offset(c.Row - DBR.Row).Resize(DBR.Rows.Count + DBR.Row - c.Row).Delete     'delete that part of the listobject
                    End If
               End If
          End If
          On Error GoTo 0
     End With
End Sub

report.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info	city2
7	10	John	None	bronx01	10/10/2020	Non-Available	1	500	789546521	bronx
8	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850	1256987569	bronx
9	15	Jack	None	bronx	9/21/2020	Non-Available	6	850	1256987569	bronx
10										zzz
11										zzz
12	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750	654789546	brooklyn
13										zzz
14										zzz
15	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850	1256987569	brookyn
16										zzz
17										zzz
18	15	Jack	None	queens	9/21/2020	Non-Available	4	850	1256987569	queens
19
20
21
Blad2

Cell Formulas
Range	Formula
J7:J18	J7	=IF([@City]="","zzz",LEFT([@City],LEN([@City])-2*(ISNUMBER(-RIGHT([@City],2)))))

 

[Coyotex3]

Meant to say 01manhattan 02manhattan 03manhattan etc***
in the formula of city2, make right left and left right

if the last 2 characters of the city are numeric, they are omitted, no 2nd table anymore.

Sub Sorteer()
     Dim DBR
     With Range("TBL_Report").ListObject                        'your list
          With .Range
               .Sort .Cells(1, 10), xlAscending, Header:=xlYes  'sort on the new column "city2"
          End With

          a = .DataBodyRange.Columns(10).Value                  'read that column "city2"
          For i = UBound(a) - 1 To 1 Step -1                    'loop from 2nd last row to row 1
               If StrComp(a(i, 1), a(i + 1, 1), vbTextCompare) <> 0 Then     'if other city2 then
                    .DataBodyRange.Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown     'insert 2 empty rows
               End If
          Next

          On Error Resume Next
          s = "": s = .DataBodyRange.SpecialCells(xlCellTypeBlanks).Address     'address of all the blank cells in the databodyrange
          If Len(s) > 0 Then                                    'there are blank cells
               sp = Split(s, ",")                               'split the address
               Set c = .Parent.Range(sp(UBound(sp)))            'last area = empty rows at the bottom of the list
               Set DBR = .DataBodyRange
               If c.Columns.Count = DBR.Columns.Count - 1 Then  'that area : number of columns= 1 less than databodyrange
                    If DBR.Row + DBR.Rows.Count = c.Row + c.Rows.Count Then     'last row=same as last row DBR
                         DBR.Offset(c.Row - DBR.Row).Resize(DBR.Rows.Count + DBR.Row - c.Row).Delete     'delete that part of the listobject
                    End If
               End If
          End If
          On Error GoTo 0
     End With
End Sub

report.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info	city2
7	10	John	None	bronx01	10/10/2020	Non-Available	1	500	789546521	bronx
8	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850	1256987569	bronx
9	15	Jack	None	bronx	9/21/2020	Non-Available	6	850	1256987569	bronx
10										zzz
11										zzz
12	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750	654789546	brooklyn
13										zzz
14										zzz
15	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850	1256987569	brookyn
16										zzz
17										zzz
18	15	Jack	None	queens	9/21/2020	Non-Available	4	850	1256987569	queens
19
20
21
Blad2

Cell Formulas
Range	Formula
J7:J18	J7	=IF([@City]="","zzz",LEFT([@City],LEN([@City])-2*(ISNUMBER(-RIGHT([@City],2)))))

Thank you. I'll test it out.

 

[Coyotex3]

Meant to say 01manhattan 02manhattan 03manhattan etc***
in the formula of city2, make right left and left right

if the last 2 characters of the city are numeric, they are omitted, no 2nd table anymore.

Sub Sorteer()
     Dim DBR
     With Range("TBL_Report").ListObject                        'your list
          With .Range
               .Sort .Cells(1, 10), xlAscending, Header:=xlYes  'sort on the new column "city2"
          End With

          a = .DataBodyRange.Columns(10).Value                  'read that column "city2"
          For i = UBound(a) - 1 To 1 Step -1                    'loop from 2nd last row to row 1
               If StrComp(a(i, 1), a(i + 1, 1), vbTextCompare) <> 0 Then     'if other city2 then
                    .DataBodyRange.Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown     'insert 2 empty rows
               End If
          Next

          On Error Resume Next
          s = "": s = .DataBodyRange.SpecialCells(xlCellTypeBlanks).Address     'address of all the blank cells in the databodyrange
          If Len(s) > 0 Then                                    'there are blank cells
               sp = Split(s, ",")                               'split the address
               Set c = .Parent.Range(sp(UBound(sp)))            'last area = empty rows at the bottom of the list
               Set DBR = .DataBodyRange
               If c.Columns.Count = DBR.Columns.Count - 1 Then  'that area : number of columns= 1 less than databodyrange
                    If DBR.Row + DBR.Rows.Count = c.Row + c.Rows.Count Then     'last row=same as last row DBR
                         DBR.Offset(c.Row - DBR.Row).Resize(DBR.Rows.Count + DBR.Row - c.Row).Delete     'delete that part of the listobject
                    End If
               End If
          End If
          On Error GoTo 0
     End With
End Sub

report.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Report
2	User
3	Date:12/01
4	Time: 12:45
5
6	Order	Name	Description	City	Date	Info	Order #	1	Other Info	city2
7	10	John	None	bronx01	10/10/2020	Non-Available	1	500	789546521	bronx
8	15	Jack	None	bronx02	9/21/2020	Non-Available	3	850	1256987569	bronx
9	15	Jack	None	bronx	9/21/2020	Non-Available	6	850	1256987569	bronx
10										zzz
11										zzz
12	11	Jane	None	brooklyn	9/10/2020	Non-Available	2	750	654789546	brooklyn
13										zzz
14										zzz
15	15	Jack	None	brookyn	9/21/2020	Non-Available	5	850	1256987569	brookyn
16										zzz
17										zzz
18	15	Jack	None	queens	9/21/2020	Non-Available	4	850	1256987569	queens
19
20
21
Blad2

Cell Formulas
Range	Formula
J7:J18	J7	=IF([@City]="","zzz",LEFT([@City],LEN([@City])-2*(ISNUMBER(-RIGHT([@City],2)))))

Getting run time error 1004 application defined or object defined error.

 

[BSALV]

you use option explicit ?
oh, no, i used a listobject "TBL_Report" and that doesn't exist in your workbook.
So, make that listobject or rename it to your situation.

 

[Coyotex3]

you use option explicit ?
oh, no, i used a listobject "TBL_Report" and that doesn't exist in your workbook.
So, make that listobject or rename it to your situation.

Yes now I'm getting a compile error variable not defined for a = .DataBody....

 

[BSALV]

erase the "option explicit" or add this in the Dim-line

    Dim DBR, a, i, s, sp, c