I need help writing a loop that finds the 10 highest values in column "F". For each of the 10 highest values that are selected, I want to paste that value (as well as the associated values in column C, D, and E) in another spreadsheet.
Thanks
The Aggregate function is designed to ignore error values (among other things). Here's a SUB Aggregate and Large to get a threashold to triggger your copy code
Sub GetTop10(r As Range)
Dim v As Variant
Dim t As Variant
Dim i As Long
' 14 = function LARGE
' 6 = ignore error values
' 10 = get 10'th largest value
t = Application.WorksheetFunction.Aggregate(14, 6, r, 10)
v = r
For i = 1 To UBound(v, 1)
If Not IsError(v(i, 1)) Then
If v(i, 1) >= t Then
' copy r.cells(i,-2).resize(1,4) to your other sheet
End If
End If
Next
End Sub
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
Last summer, I made a pretty basic VBA for an inventory sheet. Column A lists item name, and column B, C, and D are additional info for each item listed. The inventory is two-columned (A2:D28 and G2:J28). The VBA I made makes it so that if I delete the item entry in cell A4, the info in cells B4:D4 clears automatically with it.
The question is: I've been struggling to find a way to make the cells shift up a row when the row above it is cleared, to prevent the list from accumulating empty rows as inventory items are deleted. Most examples I found online were to delete those empty cells, whereas I'd rather just clear them and keep my formatting intact.
Is there a way to shift specific cells up like that? And, it would be lovely if there was a way to shift items from the top of the second table (G2:J2) down and over to the bottom of the first table, into A28:D28.
Any help would be greatly appreciated, or even a thumb towards a relevant tutorial. Thank you!
This code is a little tricky because of the two columns you have on your screen. My code below reads the two columns into a single one, sorts blank rows to the bottom and then splits the resulting single column back into two. All of this is done without touching the cells themselves. Therefore formatting stays in place.
Option Explicit
Enum Nsp ' Table specs
' 023
' These enumerations define your table. Modify to suit
NspAnchorClm = 1 ' 1 = column A
NspTblClmCount = 4 ' number of Table Columns
NpsSpaceClmCount = 2 ' number of blank sheet columns between List Columns
NspListClmCount = 2 ' number of List Columns
NspFirstRow = 2
NspNumRows = 10 ' number of rows per List Column
End Enum
Sub ResetList()
' 023
Dim Clm() As Variant ' First sheet column of each list column
Dim ArrIn As Variant ' Input data array
Dim Cin As Long ' input column counter
Dim Rin As Long ' input row counter
Dim ArrOut As Variant ' Output data array
Dim Rout As Long ' output row counter
Dim Rng As Range ' the sheet range of varying dimension
Dim Tmp As Variant ' intermediate memory
Dim L As Integer ' List column counter
Dim C As Long ' column counter
Dim R As Long ' row counter
Clm = Array(NspAnchorClm, NspAnchorClm + NspTblClmCount + NpsSpaceClmCount)
Tmp = (NspTblClmCount * NspListClmCount) + (NpsSpaceClmCount * (NpsSpaceClmCount - 1))
Set Rng = Range(Cells(NspFirstRow, Clm(0)), _
Cells(NspFirstRow + NspNumRows - 1, Tmp))
' read all of the list into an array
ArrIn = Rng.Value
' define a single list column array
ReDim ArrOut(1 To NspNumRows * NspListClmCount, 1 To NspTblClmCount)
' transfer the data to a single list column
For L = 1 To NspListClmCount
For R = 1 To NspNumRows
Rout = (L - 1) * NspNumRows + R
For C = 1 To NspTblClmCount
Cin = Clm(L - 1) + C - 1
ArrOut(Rout, C) = ArrIn(R, Cin)
Next C
Next R
Next L
' ArrIn is cleared and re-purposed to take data from ArrOut
ReDim ArrIn(1 To UBound(ArrOut), 1 To UBound(ArrOut, 2))
Rin = 0
For Rout = 1 To UBound(ArrOut)
' skip rows where the first column is blank
If Len(ArrOut(Rout, 1)) Then
Rin = Rin + 1
For C = 1 To UBound(ArrOut, 2)
ArrIn(Rin, C) = ArrOut(Rout, C)
Next C
End If
Next Rout
' assign NspNumRows high sections of ArrIn to ArrOut
For L = 1 To NspListClmCount
ReDim ArrOut(1 To NspNumRows, 1 To NspTblClmCount)
For R = 1 To NspNumRows
For C = 1 To NspTblClmCount
ArrOut(R, C) = ArrIn(((L - 1) * NspNumRows) + R, C)
Next C
Next R
Set Rng = Cells(NspFirstRow, Clm(L - 1)).Resize(NspNumRows, NspTblClmCount)
Rng.Value = ArrOut
Next L
End Sub
I'm afraid this code will make the code you already have obsolete. If the first cell in a row is empty any content in the others will be omitted, just like your own code does.
Please pay attention to the enumeration at the top of the code. It works like a switchboard where you can enter all parameters. You can modify them as you wish. For example my code has NspNumRows = 10. Your sheet has 27 data rows per column. You will need to change that number. Just to help you find your way:-
The "AnchorColumn" is the first sheet column of the first list column. All other columns are counted from there. It need not be column A. You could leave column A blank and anchor your list in Column B (=2).
"TableColumns" are the columns that repeat in each "ListColumn". You can have more than 4 or fewer.
A "ListColumn" consists of several "TableColumns". You can have more than 2.
"SpaceColumns" are blank sheet columns inserted between "ListColumns".
NspFirstRow specifies the first data row. Above it are captions or other data which this program doesn't touch on. You could reserve the first 10 rows for something else and start your list in row 11.
By setting these 6 enumerations you can create lists of 2 or more List Columns, anywhere on the worksheets, with any number of data rows. Not all of this has been tested exhaustively. When you delete a row anywhere (in fact only the first cell of that row) the list is rewritten to move the blank row to the bottom of the last list column.
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 am trying to generate a list of data based on the contents of a group of filtered cells. First (in code not included), users select a criterion from a list box, which filters a list of 800 accounts down to the number that meet that criterion. From there, I need to grab the value from Column a and the row that corresponds to the visible cells. The issue is that I can't do a straight reference to the row, because when the rows are hidden, it is no longer a 1,2,3,4 etc sequential list. Here is the code I have, I know exactly where I need to specify the rows, just not how to do so
Sub AllProviders_Click()
Dim i As Integer
Dim vCount As Integer
vCount = Range("E18:E817").SpecialCells(xlCellTypeVisible).Count
MsgBox vCount 'for debugging
For i = 1 To vCount
Sheets("Provider Output").Cells(3, 2 + i) = 'and this is where I have no idea
Next i
End Sub
When the sub is run, the number of cells that are visible is stored in vCount, which is used to specify how many columns of data are going to be filled. My issue is line 7, where I need to specify the cells to pull.
Try:
Range("A18:A817").SpecialCells(xlCellTypeVisible).Copy _
Sheets("Provider Output").Cells(3, 3)
Edit: if that's not working for you then maybe try this -
Sub AllProviders_Click()
Dim i As Integer
Dim c As Range
i = 1
For Each c In Range("E18:E817").Cells
If Not c.EntireRow.Hidden Then
Sheets("Provider Output").Cells(3, 2 + i) = c.EntireRow.Cells(1).Value
i = i + 1
End If
Next c
End Sub
I have 2 worksheets, Main and Return. I have the values in Main and the results in Return. I am trying to find a particular position in an array containing an index value (the data comes from Main sheet) e.g. 10, 20, 40, 50, 60 etc...then take the 5 values above and 5 values below this index including the index value I am searching for and do an average of it returning the average to a cell on the sheet (to the Return sheet), thus doing an average of 11 values. So far I have managed to store the range in the array using:
Public Sub myArray()
Dim myArr() As Variant
Dim R As Long
Dim C As Long
myArr = Range("C6:D1126")
For R = 1 To UBound(myArr, 1)
For C = 1 To UBound(myArr, 2)
Debug.Print myArr(R, C)
Next C
Next R
End Sub
The search/find of value within the array and averaging has left me scratching my head...
Please help...thank you. Help with the code in the array or manipulating the data from the worksheet itself works fine by me :)
Sample file --> http://www.filedropper.com/indexes
You could use this UDF:
Function avrg(indx, rng As Range)
Dim i, minI As Long, maxI As Long
i = Application.Match(indx, rng.Columns(2), 0)
If IsError(i) Then
avrg = CVErr(xlErrNA)
Exit Function
End If
With WorksheetFunction
minI = .Max(1, i - 5)
maxI = .Min(rng.Rows.Count, i + 5)
avrg = .Average(rng.Cells(1, 1).Offset(minI - 1).Resize(maxI - minI + 1))
End With
End Function
This UDF finds first entry of value (say 10 or 20) in Index column (Main sheet) takes 5 values above and 5 below it and returns average of corresponding values of column Value (Main sheet). If you need to take average of values from column Index, change rng.Cells(1, 1) to rng.Cells(1, 2)
Also note at this lines in UDF:
minI = .Max(1, i - 5)
maxI = .Min(rng.Rows.Count, i + 5)
if we can't take 5 values below and 5 values above index i (e.g. if index of target value equals to 2) we take in first case all values from start and in second case all values untill end of range.
Then you can call it either from worksheet: enter this formula in sheet Dash cell C4: =avrg(C3,Main!$C$6:$D$1126) and drag it across.
either from VBA:
Sub test()
Dim rng As Range
Dim rngInd As Range
Dim cell As Range
Set rng = ThisWorkbook.Worksheets("Main").Range("C6:D1126")
Set rngInd = ThisWorkbook.Worksheets("Dash").Range("C3:L3")
For Each cell In rngInd
cell.Offset(1).Value = avrg(cell.Value, rng)
Next cell
End Sub
In both cases function returns #N/A if indx value not found.