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
Related
I apologize, this is my first crack at Excel VBA so excuse my lack of knowledge!
So I have a list of (currently) 3 names to assign to the days in column A in a repeating order in Excel.
Currently my VBA code allows it to populate the selected cells with the names in a repeating pattern (this part is good), however there are two pieces I need help with.
1- with current code, once it reaches the bottom of the names it checks for the blank box that would end that list and starts over at the tops as directed but it puts a blank cell first (see screenshot). How can I have it put next name without adding blank cell first?
2- I want to be able to (once this gets going)select the entire D column through what dates need to be filled and:
-check the lowest non blank box
-match to list and set the
counter to name below that so
it continues the name order
from the last person who was
assigned
This is code I have now:
Sub EXAMPLE()
Dim count As Integer
count = 0
For Each c In Selection
c.Value = Range("X1").Offset(count, 0).Value
If c.Value = "" Then count = -1 And c.Value = Range("x1").Offset(count, 0).Value
count = count + 1
Next c
End Sub
Sorry I know that was long, I hope this makes sense.
I think it's worth reading about arrays, as this task is ideally suited to their use. Your best bet would be to read the names into an array and then build a recurring array whose dimension is equal to the number of rows in your dates column (or selection, or however you want to define the size of the output range).
Code would look a little like this:
Dim v As Variant
Dim people() As Variant, output() As Variant
Dim rowCount As Long, i As Long, j As Long
Dim endRange As Range
'Read the list of names into an array.
'This just takes all data in column "X" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "X").End(xlUp)
v = .Range(.Cells(1, "X"), endRange).Value
End With
'Sense check on the names data.
If IsEmpty(v) Then
MsgBox "No names in Column ""X"""
Exit Sub
End If
If Not IsArray(v) Then
ReDim people(1 To 1, 1 To 1)
people(1, 1) = v
Else
people = v
End If
'Acquire the number of rows for repeating list of names.
'This just takes all data in column "A" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "A").End(xlUp)
rowCount = .Range(.Cells(3, "A"), endRange).Rows.Count
End With
'Sense check date data.
If endRange.Row < 3 Then
MsgBox "No dates in Column ""A"""
Exit Sub
End If
'Make a recurring array.
ReDim output(1 To rowCount, 1 To 1)
i = 1
Do While i <= rowCount
For j = 1 To UBound(people, 1)
output(i, 1) = people(j, 1)
i = i + 1
If i > rowCount Then Exit Do
Next
Loop
'Write the output to column "D"
Sheet1.Range("D3").Resize(UBound(output, 1)).Value = output
I have written this code to add numbers in a column. It is not adding the last cell.
For example if there are three numbers 1, 2 and 3 it will sum up 1 and 2 and ignore value in third cell. When there is a fourth number 1, 2, 3 and 4 it adds 1, 2 and 3.
Sub add()
Dim Rng As Range, a As Integer
Set Rng = Range("b2", Range("b2").End(xlDown))
Counter = Rng.Count
a = 0
For i = 2 To Counter
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
Let's say the Counter = Rng.Count gives 4, and you start your i = 2 (possibly to keep title of your column). Your code will not print 4 digits, because you start loop from 2.
The counter should look like this:
Counter = Rng.Count + 1
and it will work
It is because .End(xlDown) - it works like CTRL + downarrow, and ends on the last not empty, or first not empty cell in the column. That's why when you delete value in specific row it will "break" the range. If you want to scan all rows, no matter if it's empty or not use the loop from the first row, and you will get the sum of the whole column range (starting from row 2 of course):
Sub SumWholeColumn()
'give the sum of all numbers in column B, starting from B2
Dim i, a As Long
Dim column, addr As String
a = 0
column = "b"
For i = 2 To Rows.Count
addr = column & i
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
If your range is fixed, you can speed up the calculation process by setting the range manually. Otherwise it will scan ALL rows. For example if you know, that your random numbers will not exceed row 1000, then you can use something like this:
Sub SumWholeColumn()
'give the sum of all numbers in column B, starting from B2
Dim i, a As Long
Dim maxRows As Integer
Dim column, addr As String
a = 0
column = "b"
maxRows = 1000
For i = 2 To maxRows
addr = column & i
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
Well I think that at the first time I did not understood your point then, I thought you would like to paste numbers in column B from 0 to the last row, starting from the B2 address. If so - this will work:
Sub add()
Dim i, a As Long
Dim column As String
Dim addr As String
a = 0
column = "b"
For i = 2 To Rows.Count
addr = column & i
ActiveSheet.Range(addr).Value = a
a = a + 1
Next i
End Sub
but today I realised that your title "Adding numbers in a column via Excel VBA
" is wrong and probably you are trying to achieve something else (because you are trying to give some value in ActiveCell?) and if so, please correct me:
you have actually some numbers in column B, and you would like to give in the ActiveCell the sum of all those numbers? The answer for this will be:
Sub SumAll()
'give the sum of all numbers in column B, starting from B2
Dim Rng As Range
Dim a, i As Long
Set Rng = Range("b2", Range("b2").End(xlDown))
Counter = Rng.Count + 1
a = 0
For i = 2 To Counter
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
You need to use "a" as Long, because Integer is up to 2147483647 and if you fill all rows in the column, starting from 0 and iterate the number by 1 to the last row, and sum the values it will give you 2147319811 - out of the Integer scope.
i value can be Integer (not Long as in my example), because "i" max value will not exceed the scope (Workbook rows are limited to 1048576). You can safely change i to Integer and save some KB's of memory :)
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 …
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
I have a process I am trying to code in macros.
For every row in range:
I am trying to select non empty cells in a row.
For those cells, pick a minimum value n_1.
Given a multiplication factor a create an array (same length as the non empty row) of equally spaced numbers starting with the minimum value, i.e. (n_k = (a^k)*n_1).
Something along these lines
Dim a As Range, b As Range, number_of_elements as Integer
Set a = Range()
For Each b In a.Rows
Dim newarray as Variant 'initialize new array
arr = select_non_empty_cells(b) 'select non empty cells
number_of_elements = Ubound(arr) 'get number of elements
ReDim newarray(1 To number_of_elements) As Integer 'set the dimension
min_val = WorksheetFunction.Min(arr.Value) 'pick minimum value
For counter = 1 To number_of_elements 'create new array with equally spaced numbers
newarray(counter) = min_val*1.25^counter 'multiplying factor
Next counter
arr.Value = newarray.Value 'set the non empty range to new values
Next
And below is what my data will look like. So for the first row I would pick 1033.2 (the minimum value) and create new array of the same length of 5 elements evenly spaced. Same for the second row.
Perhaps something like:
Sub Korba()
Dim i As Long, mini As Long
Dim WhichRow As Long
Dim factr As Double
mini = 3
factr = 1.25
WhichRow = 5
For i = 1 To Columns.Count
With Cells(WhichRow, i)
If .Value <> "" Then Exit Sub
.Value = mini * factr ^ i
End With
Next i
End Sub