I'm currently using this VBA to sort dates in ascending order. It works well on my first worksheet but i can't seem to get it to apply to additional worksheets. Any help would be much appreciated, thanks!
Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160606
On Error Resume Next
If Application.Intersect(Target, Application.Columns(1)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
Range("A3").Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
One Code for All Worksheets
Use the following code in the ThisWorkbook module:
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Const Cols As Variant = 1 ' or "A"
Const RangeAddr As String = "A3"
Const Key1Addr As String = "A4"
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Sh.Columns(Cols)) Is Nothing Then Exit Sub
On Error Resume Next
Sh.Range(RangeAddr).Sort Key1:=Sh.Range(Key1Addr), _
Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
' While developing, a simple error handler can clarify occurring issues.
' If Err.Number <> 0 Then
' Debug.Print Err.Description
' Else
' Debug.Print "Sheet '" & Sh.Name & "' successfully sorted."
' End If
'On Error GoTo 0
End Sub
Related
Code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Range("H2").Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub
Is it possible to increase the scope of the code so that no matter where a date is entered in column A (below the A2 starting parameter) the date and row will be sorted into the correct location? Currently this code only allows the space directly after the final entry to sort.
Example:
Date
Other Info
5/12/2022
""Data
5/18/2022
''Data
5/17/2022
''Data
This produces a chart where the 5/17 will move between the 5/12 and 5/18 as it should
Example2:
Date
Other Info
5/12/2022
""Data
5/18/2022
''Data
--------
--------------
5/17/2022
''Data
This however results in nothing occurring which is what I want to increase the scope for. Is that possible?
Thanks
You could detect the last used row (examining column A) each time the event runs, with something like:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, LastRow As Long
Set ws = ActiveSheet
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Range("A2:H" & LastRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub
However, an easier way would be to just use the Target.Row, as this should suffice in your circumstances:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Range("A2:H" & Target.Row).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub
Obviously, if your table goes beyond column H, then you'll need to change that.
I have using this function which finds and replace the string throughout the entire workbook.
But i do not know why error is appearing "run time error: Object variable or with block variable not set" on rngCheck = Me.Range("A2:A37")
I tried alot to find the problem but its not find you help will be appreciated.
Sub FndRplce(fnd As String, rplc As String)
Dim sht As Worksheet
Dim boolStatus As Boolean
boolStatus = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, LookIn:=xlValues, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Application.ScreenUpdating = boolStatus
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCheck As Range
Dim strOld As String
Dim strNew As String
rngCheck = Me.Range("A2:A37")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, rngCheck) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
strNew = Target.Value
Application.Undo
strOld = Target.Value
Call FndRplce(strOld, strNew)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Please, try the next pieces of code:
1.Copy this one in the Sheet1 code module:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCheck As Range, strOld As String, strNew As String, lastR As Long
'Now, it calculates the last existing value in column "A:A":
'no need to adapt the code after adding records
lastR = Me.Range("A" & Me.Rows.Count).End(xlUp).Row
Set rngCheck = Me.Range("A2:A" & lastR)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, rngCheck) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
strNew = Target.Value
Application.Undo: strOld = Target.Value
Call FndRplce(strOld, strNew)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Copy the next Sub in a standard module. But take care to delete your existing one having the same name...
Sub FndRplce(fnd As String, rplc As String)
Dim sht As Worksheet, boolStatus As Boolean
boolStatus = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Application.ScreenUpdating = boolStatus
End Sub
Please, test it and send some feedback.
I have written a VBA macro which will sort rows based on user inputs. So if an user inputs 1, then the sorting will happen based on a certain condition, if 2 then an another condition and so on. However when I run the code I get the error "Run Time error 1004: Sort method of Range class failed". Can any of the VBA experts help how I can overcome this error. Below is the entire code block :
Public Sub Sortlist()
Dim userinput As String
Dim tryagain As Integer
userinput = InputBox("1 = Sort By Division,2 = Sort by Category, 3 = Sort by Total sales")
If userinput = "1" Then
DivisionSort
ElseIf userinput = "2" Then
CategorySort
ElseIf userinput = "3" Then
TotalSort
Else
tryagain = MsgBox("Incorrect Value.Try again?", vbYesNo)
If tryagain = 6 Then
Sortlist
End If
End If
End Sub
------------------------------------
Sub DivisionSort()
'
' Sort List by Division Ascending
'
'
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
----------------------------------------------
Sub CategorySort()
'
' Sort List by Category Ascending
'
'
Selection.Sort Key1:=Range("B4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
--------------------------------
Sub TotalSort()
'
' Sort List by Total Sales Ascending
'
'
Selection.Sort Key1:=Range("F4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
CurrentRegion Saves the Day
Your code was failing when your Selection was out of range. So I created a Sub with one argument called SortRange which uses CurrentRegion to always 'point' to the range.
Option Explicit
Public Sub Sortlist()
Dim userinput As String
Dim tryagain As Integer
userinput = InputBox("1 = Sort By Division,2 = Sort by Category, 3 = Sort by Total sales")
If userinput = "1" Then
DivisionSort
ElseIf userinput = "2" Then
CategorySort
ElseIf userinput = "3" Then
TotalSort
Else
tryagain = MsgBox("Incorrect Value.Try again?", vbYesNo)
If tryagain = 6 Then
Sortlist
End If
End If
End Sub
'------------------------------------
Sub SortRange(rng As Range)
rng.CurrentRegion.Sort Key1:=rng, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
'------------------------------------
Sub DivisionSort()
'
' Sort List by Division Ascending
'
SortRange Range("A4")
End Sub
'----------------------------------------------
Sub CategorySort()
'
' Sort List by Category Ascending
'
SortRange Range("B4")
End Sub
'--------------------------------
Sub TotalSort()
'
' Sort List by Total Sales Ascending
'
SortRange Range("F4")
End Sub
I had the same issue when doing an online Excel VBA course. Likely the same course. The error was in the course supplied spreadsheet. I managed to troubleshoot the problem and it was relating to this issue found on the web.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/block-if-without-end-if?
So a simpler fix but then my PC rebooted and I lost the macro that I edited and got to work.
I tried the VBasic2008 "Fix" and that works perfectly fine as well.
Just my comments on what I went thru, not trying to persuade or dissuade otherwise.
Barry
I need your help,
I can't seem to get the next or previous buttons to work with the .FindNext and FindPrevious functions of excel.
My aim is to create a user form where the user can use the next and prev buttons to go back and fourth between the found matches of "test". I thought that by globalizing the variable foundCell, I might be able to accomplish this, but I was epically wrong.
Dim foundCell
Private Sub btnSearch_Click()
With Sheet1
Set foundCell = .Cells.find(What:="test", After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Bingo"" found in row " & foundCell.Row)
form1.location.Value = Cells(foundCell.Row, 1).Value
Else
MsgBox ("Bingo not found")
End If
End Sub
Private Sub btnNext_Click()
foundCell.FindNext
form1.location.Value = Cells(foundCell.Row, 1).Value
End Sub
Private Sub btnPrev_Click()
foundCell.FindPrevious
form1.location.Value = Cells(foundCell.Row, 1).Value
End Sub
I would take your search routine and move it into a sub routine. Then you can just call it by passing in a few params. like the starting cell to search from and which direction to go.
Private Sub btnSearch_Click()
dosearch Cells(1, 1), Excel.xlNext
End Sub
Private Sub btnNext_Click()
dosearch foundCell, Excel.xlNext
End Sub
Private Sub btnPrev_Click()
dosearch foundCell, Excel.xlPrevious
End Sub
Sub dosearch(r As Range, whichWay As Integer)
With Sheet1
Set foundCell = .Cells.Find(What:="test", After:=r, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=whichWay, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Bingo"" found in row " & foundCell.Row)
form1.Location.Value = Cells(foundCell.Row, 1).Value
Else
MsgBox ("Bingo not found")
End If
End Function
I am trying to find out how to get a database to automatically sort alphabetically using VBA in column A. Sounds easy, but I have headers in the first 4 rows and want it to sort from line 5 downwards. I have been searching for days to find a code that does this. The nearest I have succeeded is with this code-
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Range("A1").Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub
The problem is when I try changing the line
Range("A1").Sort Key1:=Range("A2"), _ to Range("A5").Sort Key1:=Range("A6"), _ when I test it, it still sorts to row 2 and not to row 5 as intended. I know I am missing something, but just cannot see what it is that I am missing!
Please do not misuse OERN (On Error Resume Next). It is like telling the code to Shut up :). Handle the error correctly.
Another interesting read
Is this what you are trying?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lRow As Long
On Error GoTo Whoa
'~> Find the last row in Col A
lRow = Range("A" & Rows.Count).End(xlUp).Row
'~~> Check if it is greater than row 4
If lRow > 4 Then
Application.EnableEvents = False
'~~> Check if the change happened in the relevant range
If Not Intersect(Target, Range("A5:A" & lRow)) Is Nothing Then
'~~> Sort only the relevant range
Range("A4:A" & lRow).Sort Key1:=Range("A4"), _
Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub