SOLVED

Need help with macro

Copper Contributor

I have the following macro that someone made for me a few years ago. In it, it is tied to a certain page. I need to be able to run the macro on the page that I am working on without having to change the page name every time.

 

Sub Macro1()
'
' Macro1 Macro
'

'
Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A8:I41").Select
ActiveWorkbook.Worksheets("June 2024").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("June 2024").Sort.SortFields.Add2 Key:=Range( _
"E7:E41"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("June 2024").Sort.SortFields.Add2 Key:=Range( _
"A8:A41"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("June 2024").Sort
.SetRange Range("A8:I41")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply

 

Dim i As Integer


For i = 2 To 5000

If Cells(i, 5).Value <> Cells(i + 1, 5).Value Then

Cells(i + 1, 5).Rows("1:1").EntireRow.Insert
i = i + 1

Else
End If


Next i
End With

End Sub

 

6 Replies

@LarryHarrison1988 

Try this version:

Sub Macro1()
    '
    ' Macro1 Macro
    '
    '
    Dim r As Long
    Dim m As Long

    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("E8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add2 Key:=Range("A8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A8:I41")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    m = Range("E" & Rows.Count).End(xlUp).Row
    For r = m - 1 To 7 Step -2
        If Range("E" & r).Value <> Range("E" & r + 1).Value Then
            Range("E" & r + 1).EntireRow.Insert
        End If
    Next r
End Sub

@HansVogelaar 

The macro sorted by column E, but not completely.

Here is the data that I am working with, this is only one page.

@LarryHarrison1988 

Does this work for you?

Sub Macro1()
    Dim r As Long
    Dim m As Long

    Application.ScreenUpdating = False

    m = Range("E" & Rows.Count).End(xlUp).Row
    Range("A7:I" & m).Sort Key1:=Range("E7"), Key2:=Range("A7"), Header:=xlYes

    For r = m - 1 To 8 Step -2
        If Range("E" & r).Value <> Range("E" & r + 1).Value Then
            Range("E" & r + 1).EntireRow.Insert
        End If
    Next r

    Application.ScreenUpdating = True
End Sub

@HansVogelaar 

Here are the results that I got. Some of the numbers in column E are not separated by a blank line.

Receipt # Date Account # Merchant     Amount    
14 4/19/2024 5400735 BELMOR  $         190.51
         
22 4/29/2024 5500037 Staples Inc  $           67.07
26 5/6/2024 5500084 THE HOME DEPOT #6537  $           27.18
         
7 4/8/2024 5500088 Staples Inc  $         122.36
10 4/15/2024 5500088 AMZN Mktp US*KT7K85B13  $           79.92
         
4 4/8/2024 5500091 DALLASCOUNTY TAXOFFICE  $         292.25
5 4/8/2024 5500091 JPMC FEE  $              6.28
         
6 4/8/2024 5510059 EZCATERMATTITOS  $         637.13
8 4/10/2024 5510059 EZCATERNORMAS CAFE  $         518.31
9 4/11/2024 5510059 EZCATERPANDA EXPRESS  $         327.85
11 4/16/2024 5510059 JASON'S DELI MSQ 019  $         493.42
12 4/19/2024 5510059 CHICK-FIL-A #03750  $         219.75
13 4/19/2024 5510059 CHICK-FIL-A #03750  $           37.89
15 4/22/2024 5510059 DOMINO'S 6916  $         141.69
16 4/23/2024 5510059 BABE'S GARLAND CATERING  $         760.40
18 4/24/2024 5510059 SPRING CREEK MESQUITE  $         170.60
20 4/25/2024 5510059 EZCATERMATTITOS  $         364.73
21 4/29/2024 5510059 POLLO REGIO - 046 - ECOMM  $         290.00
23 5/1/2024 5510059 JASON'S DELI MSQ 019  $         416.59
24 5/3/2024 5510059 DOMINO'S 6916  $         148.05
25 5/3/2024 5510059 EZCATEROUTBACK STEAKH  $         266.65
         
1 4/8/2024 5800805 CRCKR BARL #622 LUFKIN TX  $           35.33
3 4/8/2024 5800805 KIM'S #45  $              8.52
         
2 4/8/2024 5800816 FREDDY'S 23-0010  $           20.44
17 4/23/2024 5800840 CAJUN CREATIVE PRINTING L  $           67.50
19 4/25/2024 5800840 AMZN Mktp US*5535I9PB3  $           21.99
best response confirmed by LarryHarrison1988 (Copper Contributor)
Solution

@LarryHarrison1988 

My apologies, a stupid mistake on my side. Step -2 should have been Step -1.

Sub Macro1()
    Dim r As Long
    Dim m As Long

    Application.ScreenUpdating = False

    m = Range("E" & Rows.Count).End(xlUp).Row
    Range("A7:I" & m).Sort Key1:=Range("E7"), Key2:=Range("A7"), Header:=xlYes

    For r = m - 1 To 8 Step -1
        If Range("E" & r).Value <> Range("E" & r + 1).Value Then
            Range("E" & r + 1).EntireRow.Insert
        End If
    Next r

    Application.ScreenUpdating = True
End Sub
That works great. Thank you.
1 best response

Accepted Solutions
best response confirmed by LarryHarrison1988 (Copper Contributor)
Solution

@LarryHarrison1988 

My apologies, a stupid mistake on my side. Step -2 should have been Step -1.

Sub Macro1()
    Dim r As Long
    Dim m As Long

    Application.ScreenUpdating = False

    m = Range("E" & Rows.Count).End(xlUp).Row
    Range("A7:I" & m).Sort Key1:=Range("E7"), Key2:=Range("A7"), Header:=xlYes

    For r = m - 1 To 8 Step -1
        If Range("E" & r).Value <> Range("E" & r + 1).Value Then
            Range("E" & r + 1).EntireRow.Insert
        End If
    Next r

    Application.ScreenUpdating = True
End Sub

View solution in original post