Help with this custom sort and insert blank rows macro?

C

Coyotex3

Well-known Member
Joined
Dec 12, 2021
Messages
507
Office Version
  1. 365
Platform
  1. Windows
Hello, so I will have a variable range like this
Automation(19128).xlsx
ABCDEFGHIJ
1Report
2User
3Date:12/01
4Time: 12:45
5
6OrderNameDescriptionCityDateInfoOrder #1Other Info
715JackNonebrookyn9/21/2020Non-Available5850.001256987569
810JohnNonebronx10/10/2020Non-Available1500.00789546521
915JackNonebronx9/21/2020Non-Available3850.001256987569
1015JackNonebronx9/21/2020Non-Available6850.001256987569
1111JaneNonebrooklyn9/10/2020Non-Available2750.00654789546
1215JackNonequeens9/21/2020Non-Available4850.001256987569
13
Sheet1


And I will use these codes

VBA Code: 
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
ABCDEFGHI
1Report
2User
3Date:12/01
4Time: 12:45
5
6OrderNameDescriptionCityDateInfoOrder #1Other Info
7
8
9
1010JohnNonebronx10/10/2020Non-Available1500.00789546521
1115JackNonebronx9/21/2020Non-Available3850.001256987569
1215JackNonebronx9/21/2020Non-Available6850.001256987569
13
14
15
1611JaneNonebrooklyn9/10/2020Non-Available2750.00654789546
17
18
19
2015JackNonebrookyn9/21/2020Non-Available5850.001256987569
21
22
23
2415JackNonequeens9/21/2020Non-Available4850.001256987569
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
ABCDEFGHI
1Report
2User
3Date:12/01
4Time: 12:45
5
6OrderNameDescriptionCityDateInfoOrder #1Other Info
7
8
9
1010JohnNonebronx0110/10/2020Non-Available1500.00789546521
1115JackNonebronx029/21/2020Non-Available3850.001256987569
1215JackNonebronx129/21/2020Non-Available6850.001256987569
13
14
15
1611JaneNonebrooklyn9/10/2020Non-Available2750.00654789546
17
18
19
2015JackNonebrookyn9/21/2020Non-Available5850.001256987569
21
22
23
2415JackNonequeens9/21/2020Non-Available4850.001256987569
25
Sheet1


And not this which is what I get when I run the code
Automation(19128).xlsx
ABCDEFGHI
1Report
2User
3Date:12/01
4Time: 12:45
5
6OrderNameDescriptionCityDateInfoOrder #1Other Info
7
8
9
1010JohnNonebronx0110/10/2020Non-Available1500.00789546521
11
12
13
1415JackNonebronx029/21/2020Non-Available3850.001256987569
15
16
17
1815JackNonebronx129/21/2020Non-Available6850.001256987569
19
20
21
2211JaneNonebrooklyn9/10/2020Non-Available2750.00654789546
23
24
25
2615JackNonebrookyn9/21/2020Non-Available5850.001256987569
27
28
29
3015JackNonequeens9/21/2020Non-Available4850.001256987569
Sheet1
 
Sort by date Sort by votes
BSALV said:
erase the "option explicit" or add this in the Dim-line
VBA Code: 
    Dim DBR, a, i, s, sp, c
Click to expand...
Just to clarify this last error was with the use of option explicit, the 1004 error was without the use of it.
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Here's another way, without the use of tables. Assumes column J is 'available' as a helper.

VBA Code: 
Option Explicit
Sub Coyotex3()
    Dim lr As Long, i As Long, j As Long, data
    Dim ws As Worksheet, rng As Range, s As String
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
    
    data = ws.Range("D7:D" & lr)
    For i = 1 To UBound(data)
        s = ""
        For j = 1 To Len(data(i, 1))
            If Not IsNumeric(Mid(data(i, 1), j, 1)) Then
                s = s & (Mid(data(i, 1), j, 1))
            End If
        Next j
        data(i, 1) = s
    Next i
    
    With ws
        .Range("J7").Resize(UBound(data)).Value = data
        .Range("A6").CurrentRegion.Sort _
        Key1:=.Range("J6"), Order1:=1, _
        Key2:=.Range("D6"), Order2:=1, _
        Key3:=.Range("B6"), Order3:=1, _
        Header:=0
    End With
    
    Set rng = ws.Range("J7:J" & lr)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) <> rng.Item(i).Offset(-1) Then
            rng.Item(i).Resize(3).EntireRow.Insert
        End If
    Next i
    ws.Range("J1").EntireColumn.ClearContents
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
kevin9999 said:
Here's another way, without the use of tables. Assumes column J is 'available' as a helper.

VBA Code: 
Option Explicit
Sub Coyotex3()
    Dim lr As Long, i As Long, j As Long, data
    Dim ws As Worksheet, rng As Range, s As String
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
   
    data = ws.Range("D7:D" & lr)
    For i = 1 To UBound(data)
        s = ""
        For j = 1 To Len(data(i, 1))
            If Not IsNumeric(Mid(data(i, 1), j, 1)) Then
                s = s & (Mid(data(i, 1), j, 1))
            End If
        Next j
        data(i, 1) = s
    Next i
   
    With ws
        .Range("J7").Resize(UBound(data)).Value = data
        .Range("A6").CurrentRegion.Sort _
        Key1:=.Range("J6"), Order1:=1, _
        Key2:=.Range("D6"), Order2:=1, _
        Key3:=.Range("B6"), Order3:=1, _
        Header:=0
    End With
   
    Set rng = ws.Range("J7:J" & lr)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) <> rng.Item(i).Offset(-1) Then
            rng.Item(i).Resize(3).EntireRow.Insert
        End If
    Next i
    ws.Range("J1").EntireColumn.ClearContents
    Application.ScreenUpdating = True
End Sub
Click to expand...
Also getting an application 1004 error with this code for some reason. Column J is available as well.
 
Upvote 0
kevin9999 said:
On which line of code does this occur?
Click to expand...
When it gets to this:

VBA Code: 
.Range("A6").CurrentRegion.Sort _
        Key1:=.Range("J6"), Order1:=1, _
        Key2:=.Range("D6"), Order2:=1, _
        Key3:=.Range("B6"), Order3:=1, _
        Header:=0
 
Upvote 0
OK try changing
VBA Code: 
.Range("A6").CurrentRegion.Sort

to
VBA Code: 
.Range("D7").CurrentRegion.Sort
 
Upvote 0
OK, I've changed the reference from ActiveSheet to Sheet1. Other than that, I copied your data & tested it - and the code works fine. If this doesn't work for you, I'm sorry I'm unable to help you further.

VBA Code: 
Option Explicit
Sub Coyotex3()
    Dim lr As Long, i As Long, j As Long, data
    Dim ws As Worksheet, rng As Range, s As String
    Application.ScreenUpdating = False
    Set ws = Worksheets("Sheet1")
    lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
    
    data = ws.Range("D7:D" & lr)
    For i = 1 To UBound(data)
        s = ""
        For j = 1 To Len(data(i, 1))
            If Not IsNumeric(Mid(data(i, 1), j, 1)) Then
                s = s & (Mid(data(i, 1), j, 1))
            End If
        Next j
        data(i, 1) = s
    Next i
    
    With ws
        .Range("J7").Resize(UBound(data)).Value = data
        .Range("A6").CurrentRegion.Sort _
        Key1:=.Range("J6"), Order1:=1, _
        Key2:=.Range("D6"), Order2:=1, _
        Key3:=.Range("B6"), Order3:=1, _
        Header:=0
    End With
    
    Set rng = ws.Range("J7:J" & lr)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) <> rng.Item(i).Offset(-1) Then
            rng.Item(i).Resize(3).EntireRow.Insert
        End If
    Next i
    ws.Range("J1").EntireColumn.ClearContents
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
kevin9999 said:
OK, I've changed the reference from ActiveSheet to Sheet1. Other than that, I copied your data & tested it - and the code works fine. If this doesn't work for you, I'm sorry I'm unable to help you further.

VBA Code: 
Option Explicit
Sub Coyotex3()
    Dim lr As Long, i As Long, j As Long, data
    Dim ws As Worksheet, rng As Range, s As String
    Application.ScreenUpdating = False
    Set ws = Worksheets("Sheet1")
    lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
   
    data = ws.Range("D7:D" & lr)
    For i = 1 To UBound(data)
        s = ""
        For j = 1 To Len(data(i, 1))
            If Not IsNumeric(Mid(data(i, 1), j, 1)) Then
                s = s & (Mid(data(i, 1), j, 1))
            End If
        Next j
        data(i, 1) = s
    Next i
   
    With ws
        .Range("J7").Resize(UBound(data)).Value = data
        .Range("A6").CurrentRegion.Sort _
        Key1:=.Range("J6"), Order1:=1, _
        Key2:=.Range("D6"), Order2:=1, _
        Key3:=.Range("B6"), Order3:=1, _
        Header:=0
    End With
   
    Set rng = ws.Range("J7:J" & lr)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) <> rng.Item(i).Offset(-1) Then
            rng.Item(i).Resize(3).EntireRow.Insert
        End If
    Next i
    ws.Range("J1").EntireColumn.ClearContents
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you Kevin. I will test this one out and report back.
 
Upvote 0
kevin9999 said:
OK, I've changed the reference from ActiveSheet to Sheet1. Other than that, I copied your data & tested it - and the code works fine. If this doesn't work for you, I'm sorry I'm unable to help you further.

VBA Code: 
Option Explicit
Sub Coyotex3()
    Dim lr As Long, i As Long, j As Long, data
    Dim ws As Worksheet, rng As Range, s As String
    Application.ScreenUpdating = False
    Set ws = Worksheets("Sheet1")
    lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
   
    data = ws.Range("D7:D" & lr)
    For i = 1 To UBound(data)
        s = ""
        For j = 1 To Len(data(i, 1))
            If Not IsNumeric(Mid(data(i, 1), j, 1)) Then
                s = s & (Mid(data(i, 1), j, 1))
            End If
        Next j
        data(i, 1) = s
    Next i
   
    With ws
        .Range("J7").Resize(UBound(data)).Value = data
        .Range("A6").CurrentRegion.Sort _
        Key1:=.Range("J6"), Order1:=1, _
        Key2:=.Range("D6"), Order2:=1, _
        Key3:=.Range("B6"), Order3:=1, _
        Header:=0
    End With
   
    Set rng = ws.Range("J7:J" & lr)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) <> rng.Item(i).Offset(-1) Then
            rng.Item(i).Resize(3).EntireRow.Insert
        End If
    Next i
    ws.Range("J1").EntireColumn.ClearContents
    Application.ScreenUpdating = True
End Sub
Click to expand...
Mate thank you so much. This works. Sorry it took me so long to get back to you.

Would this code work if I had something like 01bronx01 02bronx02 etc?
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Duplicate row based on cell with text separated by semicolon
Replies
5
Views
106
JEC
JEC
F
  • Solved
Formula to show in 4 columns the letters from one column with condition
Replies
6
Views
302
Fractalis
F
G
  • Solved
If Else Loop macro running slow, anyway to speed it up?
Replies
9
Views
300
Alex Blakenburg
A
C
  • Question Question
SUMIFS or any other formula that can help
Replies
5
Views
82
Alex Blakenburg
A
H
  • Solved
Copy or Transpose multiple columns into a single column.
Replies
2
Views
81
harzer
H

Forum statistics

Threads
1,224,940
Messages
6,181,890
Members
453,068
Latest member
DCD1872

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top