Forum Discussion

LarryHarrison1988's avatar
LarryHarrison1988
Copper Contributor
Jul 08, 2024

Need help with macro

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

 

Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Jul 10, 2024

    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
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Jul 08, 2024

    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's avatar
        HansVogelaar
        MVP
        Jul 09, 2024

        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

Resources