I'm still trying to figure out VBA and I have a query on sorting
I have a function call MatrixSort(matrix) that takes in a n1 x n2 matrix.
Is there any sorting function that VBA has that enables me to sort the matrix by count as seen below?
Inputting the box into Matrix Sort and getting the output below:
Would appreciate if anyone can enlighten me on this
Thanks you very much!
Edit:
Thanks to pEH for your code and logic. I have came up with the function based on your idea!
Although the code might not be efficient, I realized that there isn't an easy way to do CountA since the function will substitute empty cells as 0, as such I had to manually input "" and have the counter to ignore it.
'Sorts the Matrix into Decending Count Order
'Key Idea: Calculate count in each column and saves into ArrCount
'Then use Max(ArrCount) to find the max row count
'Use Match to get the column number with the max row count, then input this to first column under MatrixOut
'Kill the count that was copied under ArrCount(iMax) = -1 so that the next maximum count can be found
'Thanks to pEH from Stackoverflow for helping out
Function MatrixSort(matrix)
Dim MatrixTemp As Variant
Dim max_row As Integer
Dim max_col As Integer
Dim p As Object
Dim i As Integer
Dim j As Integer
Dim counter As Double 'Counts the number of filled range in matrix
Dim iMax As Integer 'Stores the max count for sorting phase
MatrixTemp = matrix
'To preserve empty cells as empty instead of 0
max_row = UBound(MatrixTemp, 1)
max_col = UBound(MatrixTemp, 2)
ReDim MatrixIn(1 To max_row, 1 To max_col)
For i = 1 To UBound(MatrixTemp, 1)
For j = 1 To UBound(MatrixTemp, 2)
If MatrixTemp(i, j) = "" Then
MatrixIn(i, j) = ""
Else
MatrixIn(i, j) = MatrixTemp(i, j)
End If
Next j
Next i
Set p = Application.WorksheetFunction
'Counting of Each Columns
ReDim ArrCount(1 To max_col) 'Counts filled rows in each column
ReDim column_extract(1 To max_row) 'For CountA to work by counting each column individually
For j = 1 To max_col
For i = 1 To max_row
If MatrixIn(i, j) <> "" Then
counter = counter + 1
End If
Next i
ArrCount(j) = counter 'Stores the total count
counter = 0 'Resets the counter before another loop
Next j
'Creation of Final Output Matrix
ReDim MatrixOut(1 To max_row, 1 To max_col) 'For the Final Output
'Column Sort
For j = 1 To max_col
iMax = p.Match(p.Max(ArrCount), ArrCount, False)
For i = 1 To max_row
MatrixOut(i, j) = MatrixIn(i, iMax)
Next i
ArrCount(iMax) = -1
Next j
MatrixSort = MatrixOut
End Function
Imagine the following data:
To sort it by the count of filled rows in each column you just need to calculate that count .CountA(RngIn.Columns(iCol)) for each column and save the results into an array ArrCount.
Then you can use .Max(ArrCount) to find the maximum row count and .Match to get the column number which is maximum. This is your first column so write it to the destination RngOut. Now we just need to kill the count that was already copied ArrCount(iMax) = -1 so the next maximum can be found and copied to the next destination column … and so on …
Option Explicit
Public Sub MatrixSortColumnsByRowCount()
'input range
Dim RngIn As Range
Set RngIn = Worksheets("Sheet1").Range("B2:F8")
'output range
Dim RngOut As Range
Set RngOut = Worksheets("Sheet1").Range("B12:F18")
'count filled rows in each column
ReDim ArrCount(1 To RngIn.Columns.Count) As Long
Dim iCol As Long
For iCol = 1 To RngIn.Columns.Count
ArrCount(iCol) = Application.WorksheetFunction.CountA(RngIn.Columns(iCol))
Next iCol
'sort columns
Dim iMax As Long
For iCol = 1 To RngIn.Columns.Count
iMax = Application.WorksheetFunction.Match(Application.WorksheetFunction.Max(ArrCount), ArrCount, False)
RngOut.Columns(iCol).Value = RngIn.Columns(iMax).Value
ArrCount(iMax) = -1
Next iCol
End Sub
The output then will be …
Related
I have a data set where I need to compare the first number in each transect against each other.
For example, in the below data set I need to compare cells D2, D7, D12 and D17 and assign a value based on which one is the smallest number, the next smallest and so on. This will be used to assign the transect numbers in column A.
My issue is that the number of sections (in this example 4) and the number of transects (also 4 in this example) will vary. So the cells I need to compare will change.
I have written the code that calculates the number of transects, which is:
Dim tlength As Worksheet
Dim tb As Long *'tb=transect break*
Sub tlength_start_stop_coords()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("sheet1")
Set tlength = ThisWorkbook.Worksheets("transect lengths") *' assigns the sheet to a variable
for efficient coding*
tb = 0 *'counter to calculate the number of transects*
j = 2 *'counter for row*
Lastrow = Lastrow + 1 *'add a row to last row so that the last row includes a blank line.*
*'the following for loop is used to calculate the number of transects*
For i = 2 To Lastrow
If tlength.Range("D" & i) = vbNullString Then
If tlength.Range("D" & i - 1) <> vbNullString Then
tb = tb + 1 *'updates the counter*
End If
End If
Next i
tbtotal = tb *'stores the total counter in variable tbtotal for later use*
I think I may need to use a loop. But I am stuck trying to figure out how to manage the unknown number of comparisons in changing cell locations.
The desired result is in the below screenshot of the expected outcome, with results in column A. To begin with, I only need to get the number for the first row of each transect. Once I have that, I can copy using xldown.
Expected outcome:
Another possible data set and outcome expected might be:
enter image description here
with an expected outcome of:
enter image description here
Worked for me using your second set of sample data:
Sub Tester()
Dim tlength As Worksheet, i As Long, tNum As Long, v, vPrev, arr
Dim col As New Collection, e, c As Range, rng As Range
Set tlength = ThisWorkbook.Worksheets("transect lengths")
'collect all the Section 1 Latitudes and row numbers
For i = 2 To tlength.Cells(Rows.Count, "B").End(xlUp).Row
If tlength.Cells(i, "B") = 1 Then
col.Add Array(i, tlength.Cells(i, "D").Value) 'store start row and first Latitude
End If
Next i
SortCollection col, 2 'sort collection by second element in each array
tNum = 0
'loop over the sorted collection and assign the order of the transects
For Each e In col
tNum = tNum + 1
Set c = tlength.Cells(e(0), "B")
'following assumes all transects have at least 2 sections...
tlength.Range(c, c.End(xlDown)).Offset(0, -1).Value = tNum
Next e
End Sub
'Sort a collection of 0-based arrays in ascending order by the n'th element of each array
'Adapted from https://stackoverflow.com/a/3588073/478884
Sub SortCollection(col As Collection, n As Long)
Dim i As Long, j As Long, vTemp As Variant
For i = 1 To col.Count - 1 'Two loops to bubble sort
For j = i + 1 To col.Count
If col(i)(n - 1) < col(j)(n - 1) Then 'change to > for ascending sort
vTemp = col(j) 'store the lesser item
col.Remove j 'remove the lesser item
col.Add Item:=vTemp, before:=i 're-add the lesser item before the greater Item
End If
Next j
Next i
End Sub
I have a 100 row x 3 column table titled "WW60_STRI" where column 1 has increasing distance measurements in feet from 0.00ft at A1 to 999.99ft at A100.
I need to pull data from column 3 based on a range in column 1. specifically, I want to retrieve the max of col 3 range while col 1 ranges are <= 35.87ft. So I only want to look at col 3 range that correlate with col 1 range that is <= variable "s"
What would be the correct VBA syntax to use in my case? Thank you for your help. This is what I have so far:
Sub wshear()
Dim s As Double
s = 35.87
Dim row As Integer
Dim tbl As Range
Dim rng As Range
Set tbl = Range("WW60_STRI")
Set rng = tbl.Columns(1)
'find what position in col 1 the Split is at - position where depth > s
For Each cll In rng
If cll.Value > s Then
row = cll.row 'save row number
Exit For
End If
Next
'get length of array
Dim u As Integer
Dim l As Integer
Dim y As Integer
u = UBound(rng)
l = LBound(rng)
y = u - l + 1
'use position number "row" to define a range of cells in column 3
'get max/min out of that range
max_above_el_s = Application.WorksheetFunction.Max(Range(tbl(0, 3),tbl(row, 3))) 'I assume format is (row,col) confirm
max_below_el_s = Application.WorksheetFunction.Max(Range(tbl(row+1, 3),tbl(y, 3))) 'I assume format is (row,col) confirm
End Sub
Something like this should work:
Sub wshear()
Const s As Double = 35.87 'use const for fixed values
Dim row As Long, arr, mx, v
arr = Range("WW60_STRI").Value 'arr is a 2D array (1 to 100,1 to 3)
For row = 1 To UBound(arr, 1) 'loop over array "rows"
If arr(row, 1) <= s Then 'within threshold?
v = arr(row, 3)
mx = IIf(IsEmpty(mx), v, IIf(v > mx, v, mx)) 'track max value
End If
Next row
Debug.Print "Max value is " & mx
End Sub
can you please guide how to put array values in multiple columns like first four values in first column , than 5 values in second column, and than may be 2 in second column….. and so on. i tried do while loop and for loop but the results are not satisfactory ————————-
Sub PickNamesAtRandom()
Dim HowMany As Long
Dim NoOfNames As Long
Dim RandomColumn As Integer
Dim RandomRow As Integer
Dim Names() As String ‘Array to store randomly selected names
Dim i As Byte
Dim CellsOutRow As Integer
Dim CellsOutColumn As Integer ‘Variable to be used when entering names onto worksheet
Dim ArI As Byte ‘Variable to increment through array indexes
Application.ScreenUpdating = False
HowMany = WorksheetFunction.Sum(Sheets(“test”).Range(“A2:E2”))
CellsOutRow = 3
CellsOutColumn = 1
ReDim Names(1 To HowMany) ‘Set the array size to how many names required
NoOfNames = Application.CountA(Sheets(“sheet1”).Range(“D4:L45”)) ‘ Find how many names in the list
i = 1
Do While i <= HowMany
RandomNo:
RandomRow = Application.RandBetween(1, 45)
RandomColumn = Application.RandBetween(1, 15)
'Check to see if the name has already been picked
For ArI = LBound(Names) To UBound(Names)
If Names(ArI) = Sheets("sheet1").Cells(RandomRow, RandomColumn).Value Then
GoTo RandomNo
End If
Next ArI
Names(i) = Sheets("sheet1").Cells(RandomRow, RandomColumn).Value ' Assign random name to the array
i = i + 1
Loop
Dim RequiredRows As Integer
RequiredRow = 2
'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)
Do
Cells(CellsOutRow, CellsOutColumn) = Names(ArI)
CellsOutRow = CellsOutRow + 1
Loop While CellsOutRow < Cells(RequiredRow, CellsOutColumn).Value
CellsOutColumn = CellsOutColumn + 1
Next ArI
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub WriteValues(ByVal values As Collection)
Dim row As Long
Dim col As Long
Dim val As Variant
row = 1
For Each val In values
Select Case row
' first four values in first column
Case Is <= 4
col = 1
' than 5 values in second column,
Case Is <= 9
col = 2
' and than may be 2 in second column...
Case Is <= 11
col = 2
' row > 11
Case Else
col = 3
End Select
Cells(row, col).Value = val
row = row + 1
Next val
End Sub
I'm VERY new to Excel VBA. I want to write a function that offsets the cells in the current vector (the range selected by the user) by an amount also specified by the user.
The cells must be moved up out of the array by "n", and must then be displayed at the bottom of the same array after the remaining cells have moved up to take the place of the cells shifted up and out of the array.
Any advice will be greatly appreciated, the current code I wrote is not working and I know too little to help myself.
Many thanks!
Function ShiftVector(rng As Range, n As Integer)
'User selects a vector and inputs an integer.
'The vector must be sorted upwards by the amount equal to the entered integer
Dim i As Integer, rw As Integer, temp As Variant
rw = rng.rows.Count
ReDim b(1 To rw) As Variant
ReDim temp(1 To n) As Variant
b = rng
For i = 1 To n
temp = b(i)
'move the data in cells i=1 to n to the temporary array
Next i
b(i) = rng.Offset(-n, 0)
'move the cells in array b up by n
For i = rw - n To nr
b(i) = temp
i = i + 1
'I'm not sure if this is correct: I want to replace the top shifted cells
'back into the bottom of array b
Next i
ShiftVector4 = b
'The function must output the newly assembled array b where
'the top cells that were moved up n-spaces are now wrapped
'around and are shown at the bottom of the array b
End Function
Something like this should work:
Sub Tester()
ShiftUp Range("B4:C13"), 3
End Sub
Sub ShiftUp(rng As Range, numRows As Long)
Dim tmp
With rng
tmp = .Rows(1).Resize(numRows).Value
.Rows(1).Resize(.Rows.Count - numRows).Value = _
.Rows(numRows + 1).Resize(.Rows.Count - numRows).Value
.Rows((.Rows.Count - numRows) + 1).Resize(numRows).Value = tmp
End With
End Sub
As a UDF:
Function ShiftUp(rng As Range, numRows As Long)
Dim d, dOut, r As Long, c As Long, rMod As Long, rTot As Long
Dim break As Long
d = rng.Value
dOut = rng.Value 'as a shortcut to creating an empty array....
rTot = UBound(d, 1)
break = rTot - numRows
For r = 1 To rTot
For c = 1 To UBound(d, 2)
'figure out which input row to use...
rMod = IIf(r <= break, r + numRows, -(break - r))
dOut(r, c) = d(rMod, c)
Next c
Next r
ShiftUp = dOut
End Function
Note this is an array formula, so you will need to select a range the same size as the input range and enter the formula using CtrlShiftEnter
I have and excel document that looks like this:
and i want it to be like:
*comma (,) means that data are in different cells horizontally.
is there any vb macro or an expression to do it?
If all of the Rows have the same number of columns, then you can use INDEX, INT, COUNTA and MOD to break this down.
Column A:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),1)
Column B:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),2+MOD(ROW()-1,COUNTA(Sheet1!$1:$1)-1))
Where Sheet1!$A$1:$D$2 is the 'Input' range, and Sheet1!$1:$1 is any row in that range with a full row of data.
INDEX lets you get a specific row/column of a range. Our Range is Sheet1!$A$1:$D$2, and the Row is the same for both formulae:
1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),
This will be 1 for n rows, 2 for the next n, etc, where n is the number of cells in a row minus the starter column (i.e. how many names per gender)
(INT removes the decimal part of a number, so INT(3/4) is INT(0.75), which is 0. COUNTA just counts the non-blank cells)
The difference between the two is the Column. In column A, we just want the first column, so Column is 1. In column B, we want the xth item after the first column, where x A) counts up by 1 each row and B) resets to 1 when we go from Male to Female (or beyond)
Now, the MOD function lets us do that fairly simply: MOD(0, 3) is 0, MOD(1, 3) is 1, MOD(2, 3) is 2, and MOD(3, 3) is back to 0. We just need to start out row count at 0 (subtract 1 from Row, and add it back outside the MOD) and remove the first column from the items-per-row (subtract 1 from the COUNTA, add 1 outside the MOD)
A straightforward solution would be to use Split
Sub TransferIt()
Const SEP = ","
Dim rg As Range
Dim vdat As Variant
Dim lDat As Variant
Dim i As Long, j As Long
Dim col As Collection
' Assumption data is in column A, adjust accordingly
Set rg = Range("A1:A4")
vdat = WorksheetFunction.Transpose(rg)
Set col = New Collection
For i = LBound(vdat) To UBound(vdat)
lDat = Split(vdat(i), SEP)
For j = LBound(lDat) + 1 To UBound(lDat)
' first field always contains female or male
col.Add lDat(LBound(lDat)) & SEP & lDat(j)
Next j
Next i
vdat = collectionToArray(col)
' Write data into column B
Range("B1").Resize(UBound(vdat) + 1) = WorksheetFunction.Transpose(vdat)
End Sub
' Source: http://www.iwebthereforeiam.com/iwebthereforeiam/2004/06/excel-vba-code-to-convert-coll.html
Function collectionToArray(c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.Item(i)
Next
collectionToArray = a
End Function
Before:
After:
Code:
Sub settupp()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
n = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To n
namee = Cells(i, 1).Value
For j = 2 To 4
numberr = Cells(i, j).Value
s2.Cells(k, 1) = namee
s2.Cells(k, 2) = numberr
k = k + 1
Next
Next
End Sub