I have the above code, that finds the five max values from a column.
I need to do the same but for the minimum values higher then zero.
I need this to be in VBA because the user can change the values after in the worksheet.
I had already changed max for min, but get errors.
Sub best()
Dim maxvalue As Long
Dim copyrow As Long
copyrow = 30
Dim prevval As Long
Dim prevrow As Long
Dim i As Long
Dim fndrow As Long
prevval = 0
prevrow = 0
For i = 1 To 5
maxvalue = WorksheetFunction.Large(Sheets("Resumo").Range("J11:J47"), i)
If maxvalue <> prevval Then
fndrow = Sheets("Resumo").Range("J11:J47").Find(What:=maxvalue, LookIn:=xlValues, lookat:=xlWhole).Row
Else
fndrow = Sheets("Resumo").Range("J" & prevrow & ":J47").Find(What:=maxvalue, LookIn:=xlValues, lookat:=xlWhole).Row
End If
Dim vendor As String
vendor = Sheets("Resumo").Range("G" & CStr(fndrow))
Sheets("os melhores").Range("F" & CStr(copyrow)) = maxvalue
If InStr(vendor, " ") <> 0 Then
Sheets("os melhores").Range("G" & CStr(copyrow)) = Left(vendor, InStr(vendor, " "))
Sheets("os melhores").Range("H" & CStr(copyrow)) = Right(vendor, InStr(vendor, " "))
Else
Sheets("os melhores").Range("G" & CStr(copyrow)) = Sheets("Resumo").Range("G" & CStr(fndrow))
End If
prevval = maxvalue
prevrow = fndrow
copyrow = copyrow + 1
Next i
End Sub
File
Thanks in advance
You don't need to use a macro to solve this question or your original question about the top 5. You can use an array formula.
Please see this screen shot for reference:
Setup:
A1:A7 has data, you will need to update with your range
C2 has the formula in C3
C3:C7 have the top 5 largest values
D2 has the formula in D3
D3:D7 have the top 5 small values that are greater than 0
Taking the Max as an example, put the formula in cell C3 and press enter. You will then get the largest number. From there highlight cell C3 and press shift down 4 times so you highlight the next 4 rows. Then go into the formula bar and click the formula like you want to edit it. From there press ctrl+shift+enter (PC) command+enter (apple, I think) and it will fill in the remaining cells. They will update as you change the values in the referenced range.
Here is a screen shot of what it should look like to do the array formula:
As you can see, the cell with the formula is the main cell with focus while the next 4 cells are highlighted. The cursor is in the formula box and then press the ctrl+shift+enter.
Minor Update:
You don't even need an array formula to solve the largest 5. You could just set each excel to LARGE(A1:A7, 1) then the next cell as LARGE(A1:A7, 2) then the next cell as LARGE(A1:A7, 3), etc..
You could try this:
Option Explicit
Sub best()
Dim copyrow As Long
Dim helpRng As Range
copyrow = 30
With Worksheets("Resumo")
With .Range("J11:J47")
Set helpRng = .Offset(, .Parent.UsedRange.Columns.Count)
helpRng.Value = .Value
helpRng.Offset(, 1).Value = .Offset(, -7).Value
Set helpRng = helpRng.Resize(.Rows.Count + 1, 2).Offset(-1)
End With
End With
With helpRng
.Cells(1, 1).Resize(, 2) = "header"
.Sort key1:=helpRng, order1:=xlAscending, Header:=xlYes
.AutoFilter field:=1, Criteria1:=">0"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
Worksheets("os melhores").Cells(copyrow, "F").Resize(5, 2).Value = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Resize(5).Value
Worksheets("os melhores").Cells(copyrow, "G").Resize(5).TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=True, Space:=True
End If
.Parent.AutoFilterMode = False
.ClearContents
End With
End Sub
and change order1:=xlAscending to order1:=xlDescending to have the top five highest values report in "os melhores" worksheet
Based on the code, I think the error is caused by that if you change WorksheetFunction.Large to WorksheetFunction.Small (which you did, right?) then maxvalue can be 0, so 0 is not a dedicated 'invalid value' anymore. You can do one of the following:
declare maxvalue as variant and use a different value to mean invalid, e.g. "n/a", examine if maxvalue is this one in the first If.
(and this also helps to filter out 0's and negative values) The first parameter of WorksheetFunction.Large should be another Worksheet function that excludes, negative (or non-positive values), like you would do it in a formula:
=IF( 0 < a, a, bignumber )
Write an algorithm to store the values and the line numbers into a fixed size array.
Related
I'm trying to count the number of cells between two cells that I need to find with vba. The first cell is going to be in the same column as the current date today. The column headers are left to right in date order (May 1st, May 2nd, May 3rd, etc..). Once I find the column to begin with, I need to count the number of cells backwards that contain 0 until I find a cell without a 0. So say I'm starting in column U, I need to count the number of contiguous cells with 0 until say column R has a 1. My answer would then be 2 because columns T and S had 0's.
The issue I'm running into with the below code is that I'm trying to find first the column I'm supposed to be in based on the date (This part works). Next I'm declaring the rowNum as the activecell row number (This part work). Next I need to find which column to count backwards to (This part does not work). I'm getting the same column number on the colNum FIND code as I am the colStart FIND code.
I'm not getting any errors, it just doesn't seem like it's finding the previous cell with 0 and is instead just giving me the same column. I hope this is clear. Let me know if you need any additional info. Thanks everyone!
today = Date
colNum = Cells.Find(today, searchorder:=xlByRows,
searchdirection:=xlPrevious).Column
rowNum = ActiveCell.Row
colStart = Cells.Find(0, after:=Cells(rowNum, colNum),
searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
Try this code:
Public Function countZeros(ws As Worksheet, rowNum As Long, colNum As Long, Optional stopColumn As Long = 1) As Long
Dim currentCol As Long
countZeros = 0
If colNum <= stopColumn Then Exit Function 'prevents going past a certain point (for example your label column)
For currentCol = colNum - 1 To stopColumn + 1 Step -1
If ws.Cells(rowNum, currentCol) = 0 Then
countZeros = countZeros + 1
Else
Exit Function
End If
Next 'currentCol
End Function
Public Sub mySub()
Dim colNum As Long
Dim rowNum As Long
Dim output As String
Dim today
Dim rng As Range
today = Date
Set rng = Cells.Find(today, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "Did not find todays date, make sure your active cell is in the right location"
Exit Sub
End If
colNum = rng.Column
rowNum = ActiveCell.Row
output = "Total number of cells from " & Cells(rowNum, colNum).Address & " that have zeros: "
output = output & CStr(countZeros(ActiveWorkbook.ActiveSheet, rowNum, colNum))
MsgBox output
End Sub
With this data set:
you get the output:
Total number of cells from $K$7 that have zeros: 6
I am having trouble in counting the distance between values that are similar because there’s no function in excel that could achieve this and I deal with 2000 row of values. I would prefer excel-vba for this, a button perhaps that generates distances like in the example. array formulas lags the excel when there's too many values. Counting them 1 by 1 would be a waste of time. Please I want to have this done. I would truly appreciate it if some genius out there could pull this off.
Example bellow shows how far a specific value from the other:
you could try this
Option Explicit
Sub main()
Dim cell As Range, f As Range
Dim rowOffset As Long
With Worksheets("gaps").Range("A2:F10") '<--| change this to your actual range of interest
For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers)
rowOffset = 1
Set f = .Find(what:=cell, after:=cell, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
If Not f Is Nothing And f.Row <= cell.Row Then rowOffset = cell.Row - f.Row + 1
cell.offset(, .Columns.Count + 1) = rowOffset '<--| the "+1" offset results range one column away from values range: adjust it as per your needs
Next cell
End With
End Sub
tested on your "Values" it gives back the same "Value row gaps" except cell "K4": I hope it's a miscount on your part...
should you ever need to display output in the same "relative" position but on another worksheet (say: "sheet2") then just change
cell.offset(, .Columns.Count + 1) = rowOffset
to
Worksheets("sheet2").Range(cell.offset(, .Columns.Count + 1).Address) = rowOffset
I have the following column (1):
1
15
150
1500000
06700
07290
07500
2
22
220
2200000
00900
This would need to become 2 columns
1
15
150
1500000 06700
1500000 07290
1500000 07500
2
22
220
2200000 00900
My initial idea:
Create the extra column.
Looping through the rows, register the cell and value in variables when a number with lenght of 7 digits is found.
Move the values under it to column B until the lenght of values is <> 5
Start from cell saved in variable and copy value from variable to column A until column A is no longer Empty
After the above proces, loop rows and delete where A is lenght 7 and B is empty.
As i am not familiar with VBA, before i plunge into, i would like to verify this above set of rules would do what i intend it to do, if it's technically feasable with VBA macro's and wether or not it could result to unexpected behaviour.
This code would have to run every month on a new large excel file.
Whether your 5 digit (c/w/ leading zeroes) numbers are true numbers with a cell formatting of 00000 or text-that-look-like-numbers with a Range.PrefixCharacter property, the Range.Text property should be able to determine their trimmed length from the displayed text.
The following code follows your logic steps with a few modifications; the most obvious one is that it walks from the bottom of column A to the top. This is to avoid skipping rows that have been deleted.
Sub bringOver()
Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant
'put the cursor anywhere in here and start tapping F8
'it will help if you can also see the worksheet with your
'sample data
ReDim vVAL5s(0) 'preset some space for the first value
With Worksheets("Sheet1") '<~~ set this worksheet reference properly!
'ensure a blank column B
.Columns(2).Insert
'work from the bottom to the top when deleting rows
'or you risk skipping a row
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'determine the length of the trimmed displayed length
'and act accordingly
Select Case Len(Trim(.Cells(rw, 1).Text))
Case Is < 5
'do nothing
Case 5
'it's one to be transferred; collect it
vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text
'make room for the next
ReDim Preserve vVAL5s(UBound(vVAL5s) + 1)
Case 7
'only process the transfer if there is something to transfer
If CBool(UBound(vVAL5s)) Then
'the array was built from the bottom to the top
'so reverse the order in the array
ReDim vREV5s(UBound(vVAL5s) - 1)
For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1
vREV5s(UBound(vREV5s) - v) = vVAL5s(v)
Next v
'working With Cells is like selecting htem but without selecting them
'want to work With a group of cells tall enough for all the collected values
With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1)
'move over to column B and put the values in
.Offset(0, 1) = Application.Transpose(vREV5s)
'make sure they show leading zeroes
.Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]#"
'if there was more than 1 moved over, FillDown the 7-wide value
If CBool(UBound(vREV5s)) Then .FillDown
'delete the last row
.Cells(.Rows.Count + 1, 1).EntireRow.Delete
End With
'reset the array for the next first value
ReDim vVAL5s(0)
End If
Case Else
'do nothing
End Select
'move to the next row up and continue
Next rw
'covert the formatted numbers to text
Call makeText(.Columns(2))
End With
End Sub
Sub makeText(rng As Range)
Dim tCell As Range
For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers)
tCell.Value = Format(tCell.Value2, "\'00000;#")
Next tCell
End Sub
Just before exiting the primary routine, the short helper sub is called using column B as a range of cells. This will loop through all of the numbers in column B and convert the numbers into text with leading zeroes.
As noted in the code comments, set yourself up so you can see the code sheet as well as a portion of your worksheet and start tapping F8 to step through the code. I've tried to add a form of running commentary with the notes left above many of the code lines.
After writing the logic keeping in mind Jeeped's input i ended up making it the following way:
Force convert the column A to definately be Text
Create the extra column.
Get the number of rows with data
Loop 1: If column A cell lenght is 5, move cell to column B
Loop 2: If column A cell lenght is 7, we copy the value to variable.
Loop 2: If column A cell lenght is 0, we paste variable to the cell
After the above proces, loop rows and delete where A is lenght 7 and B is empty. (reverse loop for performance)
All input on the below posted code is more than welcome. I'm open for every kind of possible optimization.
Sub FixCols()
'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim
Range("A:A").NumberFormat = "#"
Dim Cell As Range
For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells
x = x + 1
Cell = Trim(Cell)
Cell.Value = WorksheetFunction.Trim(Cell.Value)
Next
'Now insert empty column as B
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Determine rows with values for loop
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Loops to move around the data
Dim i As Long
Dim CellValue As Long
For i = 1 To LastRow
'move items to column B
If Len(Range("A" & i).Value) = 5 Then
Range("A" & i).Select
Selection.Cut
Range("B" & i).Select
ActiveSheet.Paste
End If
Next i
For i = 1 To LastRow
'if the row is a reknr we copy the value
If Len(Range("A" & i).Value) = 7 Then
CellValue = Range("A" & i).Value
End If
'Paste the reknr to the rows with item
If Len(Range("A" & i).Value) = 0 Then
Range("A" & i).Value = CellValue
End If
Next i
'Reverse loop (performance) to check for rows to delete (reknr without item)
i = LastRow
Do
If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then
Rows(i).Delete
End If
i = i - 1
Loop While Not i < 1
End Sub
I have an excel file that looks like:
12123 51212
12123.5 45832
12124 37656
12124.5 32987
12125 42445
and so on, where column A is always 0.5 increasing and column B has a certain output.
Now I have a specific value in cell E2, say 12124,23 and I want a VBA code to return, in this case, that the best matching value is in cell A3, because I need this cell location in further code, I don't need the corresponding value in column B. I don't know how to start, however. The file can be up to 30000 rows big.
I'd only like to know first which method to use, then I will try to write the code myself of course :)
JV
You don't have to use VBA for your problem, Excel will do it perfectly fine!
Try this
=vlookup(E2;A:A;2;true)
and for what you are trying to do, you HAVE TO sort your A column in an ascending fashion, or else you will get an error!
And if you do need that in VBA,
a simple for+if structure with a test like this
Function pr24(ByVal Value_To_Match As Double) As Range
For i = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) > Value_To_Match Then
If Abs(Cells(i - 1, 1) - Value_To_Match) >= Abs(Cells(i, 1) - Value_To_Match) Then
pr24 = Range(Cells(i, 1))
Else
pr24 = Range(Cells(i - 1, 1))
End If
Exit For
Else
End If
Next i
End Function
or you can use the worksheet function Vlookup
Application.WorksheetFunction.VLOOKUP()
You could use VLOOKUP function for this:-
Application.WorksheetFunction.VLOOKUP(lookup_value, table_array, column_index, range_lookup)
Set your values as below:-
lookup_value = 12124.23
table_array = would be the range Ax:Bx containing your values
column_index = 2 (the second column of table_array)
range_lookup = true
Setting range_lookup to true means that if the vlookup doesn't find the exact value it will return the closest match.
Note this will only work if the values in column A are sorted in ascending order.
Hope this helps.
You need to sort your data in column A first (smallest to largest), and then you can use a simple lookup formula:
=LOOKUP(E2,A:A)
If you don't want to sort the data, then you can use a VBA loop like so - however this is very inefficient - you should always use worksheet formulas where you can:
Sub SO()
Dim resultCell As Excel.Range
Dim checkCell As Double
Dim bestDiff As Double
checkCell = Range("E2").Value
bestDiff = checkCell
For i = 1 To Range("A" & Rows.count).End(xlUp).Row
If Range("A" & i).Value <= checkCell Then
If (checkCell - Range("A" & i).Value) < bestDiff Then
bestDiff = checkCell - Range("A" & i)
Set resultCell = Range("A" & i)
End If
End If
Next i
MsgBox "Best match is in " & resultCell.Address
Set resultCell = Nothing
End Sub
You dont'need VBA, a call co VLOOKUP Excel function will do the trick; remember to set the last parameter to true, to find a non exact match with the searched value
It should be like something similar to:
= VLOOKUP(E2, A:B, 2, true)
I am using Excel 2010 and trying to add a bunch of rows placing the sum of columns A and B in column C. If the sum is over 500 I would then like to boldface the number in column C. My code below works works mathematically but will not do the bold formatting. Can someone tell me what I am doing wrong? Thank you.
Public Sub addMyRows()
Dim row As Integer 'creates a variable called 'row'
row = 2 'sets row to 2 b/c first row is a title
Do
Cells(row, 3).Formula = "=A" & row & "+B" & row 'the 3 stands for column C.
If ActiveCell.Value > 500 Then Selection.Font.Bold = True
row = row + 1
'loops until it encounters an empty row
Loop Until Len(Cells(row, 1)) = 0
End Sub
Pure VBA approach:
Public Sub AddMyRows()
Dim LRow As Long
Dim Rng As Range, Cell As Range
LRow = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range("C2:C" & LRow)
Rng.Formula = "=A2+B2"
For Each Cell In Rng
Cell.Font.Bold = (Cell.Value > 500)
Next Cell
End Sub
Screenshot:
An alternative is conditional formatting.
Hope this helps.
Note: The formula in the block has been edited to reflect #simoco's comment regarding a re-run of the code. This makes the code safer for the times when you need to re-run it. :)