Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action.
Become a Premium Member and unlock a new, free course in leading technologies each month.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Sub Macro1()
Dim i As Long
ActiveSheet.Sort.SortFields.Clear
For i = 1 To ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A" & i & ":D" & i), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A" & i & ":D" & i)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
Next
End Sub
Sub Macro1()
Dim i As Long
ActiveSheet.Sort.SortFields.Clear
For i = 1 To ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A" & i & ":D" & i), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A" & i & ":D" & i)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
Next
End Sub
Sub differences()
Dim Cell As Variant
Dim i As Long
Dim nums2(5)
For Each Cell In Selection
i = 0
newvalue = ""
With Cell
nums = Split(.Value, " ")
nums = SortArray(nums)
.Value = Join(nums, " ")
For Each nvalue In nums
If i > 0 Then
If i > 1 Then
newvalue = newvalue & " " & nvalue - nums(i - 1)
Else
newvalue = newvalue & nvalue - nums(i - 1)
End If
End If
i = i + 1
Next
.Offset(0, 1).Value = newvalue
End With
Next Cell
End Sub
Public Function SortArray(ByRef TheArray As Variant)
Sorted = False
Do While Not Sorted
Sorted = True
For X = 0 To UBound(TheArray) - 1
If TheArray(X) > TheArray(X + 1) Then
Temp = TheArray(X + 1)
TheArray(X + 1) = TheArray(X)
TheArray(X) = Temp
Sorted = False
End If
Next X
Loop
SortArray = TheArray
End Function
Option Explicit
Public Function ValDiff(oCell As Range) As Variant
'This function takes the values listed in a cell (oCell) and calculates the difference
'(in sequence) of each number in the cell, listing the differences (again in order) in a different cell
'(e.g. if cell "D2" contains the formula "=ValDiff(A2)" then the values calculated by this
' formula will be displayed in Cell D2
'Parameter: oCell - The address of the Cell being examined (e.g. A1)-do not use quotation marks
' since this parameter is NOT a string
Dim nVal As Integer ' A Loop counter
Dim nVals As Integer ' The number of items in the cell under examination
Dim nVals2 As Integer ' Another Loop counter
Dim cRet As String ' A temporary holder for the value to eventually be returned by this function
Dim cVals() As String ' An array of the iyems listed in the "Host" cell (oCell)
Dim cVals2() As String ' A second array holding the values in cVals() but ignoring any "blank"
' values picked up due to too many spaces being used between charaters
'First lets get the values from the reference cell, where the characters are seperated by a single space
cVals = Split(oCell, " ")
'Calculate the number of values found
nVals = UBound(cVals)
'We need to weed out values which were stored as "blank" because there where spaces
'comprising of more than one "blank". This is in case user places two spaces (or more) between
'characters instead of one.
For nVal = 0 To nVals
'ignore any values woth zero length
If Len(cVals(nVal)) > 0 Then
'keep track of the number of valid items found
nVals2 = nVals2 + 1
'redimension the new array to hold valid values
ReDim Preserve cVals2(nVals2)
'now store the latest valid value in the latest cell of the new array
cVals2(nVals2) = cVals(nVal)
End If
Next
cRet = ""
'starting at the second valid value, go through each value in the new array
For nVal = 2 To nVals2
'and add to the cRet variable the numerical difference between the value being examined
'the the value of the PREVIOUS item in the array of valid values.
'Each new "difference" found is then seperated from the next by appending a "space" (" ")
cRet = Trim(cRet + CStr(Val(cVals2(nVal)) - Val(cVals2(nVal - 1)))) + " "
Next
'Lets sort the values into ascending order first
ValDiff = SortValues(cRet)
End Function
Public Function SortValues(cValues As String) As String
Dim Sorted As Boolean 'a flag to determine if any soirting has gone on
Dim x As Integer 'a counter
Dim cArray() As String ' a temporary array hlding "cValues" (values in cell)
Dim cTemp As String ' a temp holding area for a string value
'turn the values into an array
cArray = Split(cValues, " ")
'while any sorting is still going on
Sorted = False
Do While Not Sorted
Sorted = True 'assume it is sorted first
For x = 0 To UBound(cArray) - 1
If Val(cArray(x)) > Val(cArray(x + 1)) Then
cTemp = cArray(x + 1)
cArray(x + 1) = cArray(x)
cArray(x) = cTemp
'flag that it is still not fully sorted yet
Sorted = False
End If
Next x
Loop
'turn the array back into a string
cTemp = ""
For x = 0 To UBound(cArray)
cTemp = cTemp + cArray(x) + " "
Next
'and return the sorted string value back to the calling macro
SortValues = Trim(cTemp)
End Function
Macros-in-Excel-2010-9.jpg
Option Explicit
Public Function ValDiff(oCell As Range, Optional cOrder As String) As Variant
'This function takes the values listed in a cell (oCell) and calculates the difference
'(in sequence) of each number in the cell, listing the differences (again in order) in a different cell
'(e.g. if cell "D2" contains the formula "=ValDiff(A2)" then the values calculated by this
' formula will be displayed in Cell D2
'Arguments: oCell - The address of the Cell being examined (e.g. A1)-do not use quotation marks
' since this parameter is NOT a string
' cOrder - An optioanl argument to state whether the retunred string is to be in:
' Ascending Order("A")
' Descending Order ("D")
' Unsorted (leave blank. i.e. no argument to be entered)
Dim nVal As Integer ' A Loop counter
Dim nVals As Integer ' The number of items in the cell under examination
Dim nVals2 As Integer ' Another Loop counter
Dim cRet As String ' A temporary holder for the value to eventually be returned by this function
Dim cVals() As String ' An array of the iyems listed in the "Host" cell (oCell)
Dim cVals2() As String ' A second array holding the values in cVals() but ignoring any "blank"
' values picked up due to too many spaces being used between charaters
'First lets get the values from the reference cell, where the characters are seperated by a single space
cVals = Split(oCell, " ")
'Calculate the number of values found
nVals = UBound(cVals)
'We need to weed out values which were stored as "blank" because there where spaces
'comprising of more than one "blank". This is in case user places two spaces (or more) between
'characters instead of one.
For nVal = 0 To nVals
'ignore any values woth zero length
If Len(cVals(nVal)) > 0 Then
'keep track of the number of valid items found
nVals2 = nVals2 + 1
'redimension the new array to hold valid values
ReDim Preserve cVals2(nVals2)
'now store the latest valid value in the latest cell of the new array
cVals2(nVals2) = cVals(nVal)
End If
Next
cRet = ""
'starting at the second valid value, go through each value in the new array
For nVal = 2 To nVals2
'and add to the cRet variable the numerical difference between the value being examined
'the the value of the PREVIOUS item in the array of valid values.
'Each new "difference" found is then seperated from the next by appending a "space" (" ")
cRet = Trim(cRet + CStr(Val(cVals2(nVal)) - Val(cVals2(nVal - 1)))) + " "
Next
'Lets sort the balues into order if needed
Select Case UCase(Left(cOrder, 1))
Case "A"
ValDiff = SortValues(cRet, "A")
Case "D"
ValDiff = SortValues(cRet, "D")
Case Else
'do nothing!
End Select
'return the value to be placed in Cell containing the function "ValDiff()"
ValDiff = cRet
End Function
Public Function SortValues(cValues As String, Optional cOrder As String) As String
Dim Sorted As Boolean
Dim x As Integer
Dim cArray() As String
Dim cTemp As String
cArray = Split(cValues, " ")
Sorted = False
Do While Not Sorted
Sorted = True
Select Case UCase(Left(cOrder, 1))
Case "A"
For x = 0 To UBound(cArray) - 1
If Len(cArray(x)) > 0 Then
If IsGreaterThan(cArray(x), cArray(x + 1)) Then
cTemp = cArray(x + 1)
cTemp = cArray(x + 1)
cArray(x + 1) = cArray(x)
cArray(x) = cTemp
Sorted = False
Exit For
End If
End If
Next x
Case "D"
For x = 0 To UBound(cArray) - 1
If Len(cArray(x)) > 0 Then
If IsLessThan(cArray(x), cArray(x + 1)) Then
cTemp = cArray(x + 1)
cArray(x + 1) = cArray(x)
cArray(x) = cTemp
Sorted = False
Exit For
End If
End If
Next x
Case Else
'do nothing!
End Select
Loop
cTemp = ""
For x = 0 To UBound(cArray)
cTemp = cTemp + cArray(x) + " "
Next
cValues = Trim(cTemp)
End Function
Private Function IsLessThan(cVal1 As String, cVal2 As String) As Boolean
'This function tests whether the first value "IsLessThan" the second)
'This first test does not need to be done (default)
'If InStr(cVal1, "-") = 0 And InStr(cVal2, "-") > 0 Then
' IsLessThan = False
If InStr(cVal1, "-") > 0 And InStr(cVal2, "-") = 0 Then
IsLessThan = True
ElseIf Val(cVal1) < Val(cVal2) Then
IsLessThan = True
End If
End Function
Private Function IsGreaterThan(cVal1 As String, cVal2 As String) As Boolean
'This function tests whether the first value "IsGreaterThan" the second)
'This first test does not need to be done (default)
'If InStr(cVal1, "-") > 0 And InStr(cVal2, "-") = 0 Then
' IsLessThan = False
If InStr(cVal1, "-") = 0 And InStr(cVal2, "-") > 0 Then
IsGreaterThan = True
ElseIf Val(cVal1) > Val(cVal2) Then
IsGreaterThan = True
End If
End Function
Sub SelectionSortHorizontal()
Dim SelAdd() As String
SelAdd = Split(Replace(Selection.Address, "$", ""), ":")
Dim SelTop As Long, SelBottom As Long
Dim SelLeft As Long, SelRight As Long
SelTop = Range(SelAdd(0)).Row: SelBottom = Range(SelAdd(1)).Row
SelLeft = Range(SelAdd(0)).Column: SelRight = Range(SelAdd(1)).Column
Dim i As Long
For i = SelTop To SelBottom
Range(Cells(i, SelLeft), Cells(i, SelRight)).Select
Selection.Sort Key1:=Range(Cells(Selection.Row, Selection.Column), Cells(Selection.Row, Selection.Column)), _
Order1:=xlAscending, Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal
Next
Range(Cells(SelTop, SelLeft), Cells(SelBottom, SelRight)).Select
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Automate an Oracle update in Excel | 7 | 69 | |
the UDF returns #Value when i open workbook. | 19 | 46 | |
Excel 2010 - Why doesn't VBA Replace function work to remove parentheses? | 7 | 31 | |
VBA to Import multiple excel files into a worksheet | 5 | 10 |
Join the community of 500,000 technology professionals and ask your questions.