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
Related
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.
I have a piece of code that is taking up a large amount of the actual runtime. It seems like this loop actually makes Excel unresponsive at times (not 100% sure about this, but this seems to me the most likely culprit when I stepped through the code). Anyways, I want to optimize this piece of code so it doesn't take so long.
Some background:
EDIT: application.screenupdating is set to false
Sheets(1) = RawData
Sheets(2) = AreaTable
j=2 before entering the loop
rng is the range including all values in sheet1 column CJ minus the header
In sheet1 column CJ is a list of ComponentNames that I want to loop through. For each ComponentName, I want to filter column AL and copy paste (transpose) all the visible values in column AL (there will always be at least >1 value) to Sheets(2).
There are usually around 1000-1200 ComponentNames and anywhere from 10-240 values (the same values that I'm copy pasting to sheet2) for each ComponentName.
For Each cell In rng
ComponentName = cell.Value
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=ComponentName
RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1
Next cell
What changes can I make to this loop to get the process done faster?
Build an array of the ComponentName values and filter & copy/paste once instead of a thousand times.
Dim v As Long, vCOMPNAMEs As Variant
With rng
ReDim vCOMPNAMEs(.Count)
For v = LBound(vCOMPNAMEs) To UBound(vCOMPNAMEs)
vCOMPNAMEs(v) = rng.cells(v + 1).Value2
Next v
End With
With RawData
.Range("A:CJ").AutoFilter Field:=17, Criteria1:=vCOMPNAMEs, Operator:=xlFilterValues
.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1 '<~~?????
End With
you may try something like that:
Dim outputVal As Variant, chkRng As Variant, valRng As Variant
Dim i As Long, j As Long, k As Long
With rawdata
k = .Cells(Rows.Count, 38).End(xlUp).Row
chkRng = .Range("Q2:Q" & k).Value
valRng = .Range("AL2:AL" & k).Value
ReDim outputVal(rng.Count, 0)
For Each cell In rng.Value
k = 0
For i = LBound(chkRng) To UBound(chkRng)
If chkRng(i, 1) = cell Then
outputVal(j, k) = valRng(i, 1)
k = k + 1
If k > UBound(outputVal, 2) Then ReDim Preserve outputVal(rng.Count, k)
End If
Next
j = j + 1
Next
End With
With areatable: .Range(.Cells(1, 2), .Cells(rng.Count + 1, UBound(outputVal, 2) + 2)).Value = outputVal: End With
pls test it with a copy... not having the real workbook may completely mess everything up... but it will probably end in an error...
pls try it and then tell what went wrong :)
EDIT
tested it with a small table and it worked perfectly (and also pretty fast), however: without a small example-workbook its hard to check if it will also work for you
EDIT2
the way it works: when looking for speed you need to know that everything a sheet need to do is slow. so the first part simply gets all the values to check/copy whatever and put them in variables (which is much faster in reading/writing). (chkRng and valRng)
then i generate a variable for the outputs (outputVal)
knowing there is only 1 value to check (filter) i also can compare the column with your cell. and everytime it finds a match the other value (same position) is put into the output-value (and resizing the value if needed).
lastly it pastes the outputvalue in the desired range in one step.
main downsides:
- no format will be copied (only the values, but could be changed to also copy formulas, while there is no need here)
- you need to know the exact range (to small and values will be missing / to big and an errorcode will be in each cell outside of the variable-range)
Turn calculation off before you run this, because everytime you filter, it recalculates the workbook, and if there are a lot of formulas then that will eat away at your processors:
Application.Calculation = xlCalculationManual
For Each cell In Rng
ComponentName = cell.Value
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=ComponentName
RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1
Next cell
Application.Calculation = xlCalculationAutomatic
David's suggestion is what I was going to post, that will help a lot. Also, try this (not assigning ComponentName). Untested, but should work:
For Each cell In rng
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=cell.Value
RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1
Next cell
It might also be faster to store into an array... unfortunately I don't know how many cells you're copying in... but I'll assume you're copying in 2 cells in this example, change as per your needs. Anyway, you could store results into an array and then spit out results all at once, like this:
dim arr(300000,1)
For Each cell In rng
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=cell.Value
arr(j,0) = RawData.Range("AL2")
arr(j,1) = RawData.Range("AL2").offset(1,0)
' etc.... do this for each (or create a loop to capture everything)
j = j + 1
Next cell
for j_ctr = 1 to j
AreaTable.Range("B" & j).value=arr(j_ctr,0)
AreaTable.Range("B" & j+1).value=arr(j_ctr,1)
next
unless the expensive part is the autofiltering... any way to avoid this?
I am a new user of VBA and am trying to do the following (I got stuck towards the end):
I need to locate the first empty cell across every row from column C to P (3 to 16), take this value, and paste it in the column B of the same row.
What I try to do was:
Find non-empty cells in column C, copy those values into column B.
Then search for empty cells in column B, and try to copy the first non-empty cell in that row.
The first part worked out fine, but I am not too sure how to copy the first non-empty cell in the same row. I think if this can be done, I might not need the first step. Would appreciate any advice/help on this. There is the code:
Private Sub Test()
For j = 3 To 16
For i = 2 To 186313
If Not IsEmpty(Cells(i, j)) Then
Cells(i, j - 1) = Cells(i, j)
End If
sourceCol = 2
'column b has a value of 2
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell, copy the first not empty value in that row
For currentRow = 1 To RowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If Not IsEmpty(Cells(i, 3)) Or Not IsEmpty(Cells(i, 4)) Or Not IsEmpty(Cells(i, 5)) Or Not IsEmpty(Cells(i, 6)) Then
Paste
~ got stuck here
Next i
Next j
End Sub
Your loop is really inefficient as it is iterating over millions of cells, most of which don't need looked at. (16-3)*(186313-2)=2,422,043.
I also don't recommend using xlUp or xlDown or xlCellTypeLastCell as these don't always return the results you expect as the meta-data for these cells are created when the file is saved, so any changes you make after the file is saved but before it is re-saved can give you the wrong cells. This can make debugging a nightmare. Instead, I recommend using the Find() method to find the last cell. This is fast and reliable.
Here is how I would probably do it. I'm looping over the minimum amount of cells I can here, which will speed things up.
You may also want to disable the screenupdating property of the application to speed things up and make the whole thing appear more seemless.
Lastly, if you're new to VBA it's good to get in the habit of disabling the enableevents property as well so if you currently have, or add in the future, any event listeners you will not trigger the procedures associated with them to run unnecessarily or even undesirably.
Option Explicit
Private Sub Test()
Dim LastUsed As Range
Dim PasteHere As Range
Dim i As Integer
Application.ScreenUpdating=False
Application.EnableEvents=False
With Range("B:B")
Set PasteHere = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If PasteHere Is Nothing Then Set PasteHere = .Cells(1, 1) Else: Set PasteHere = PasteHere.Offset(1)
End With
For i = 3 To 16
Set LastUsed = Cells(1, i).EntireColumn.Find("*", Cells(1, i), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If Not LastUsed Is Nothing Then
LastUsed.Copy Destination:=PasteHere
Set PasteHere = PasteHere.Offset(1)
End If
Set LastUsed = Nothing
Next
Application.ScreenUpdating=True
Application.EnableEvents=True
End Sub
Sub non_empty()
Dim lstrow As Long
Dim i As Long
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
lstrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 1 To lstrow
If IsEmpty(Range("B" & i)) Then
Range("B" & i).Value = Range("B" & i).End(xlToRight).Value
End If
Next i
End Sub
Is there a way to check if all cells in a column are less than 1? If there were only a few cells, with the number of cells known up front, I would use the code below.
However, from case to case the number of cells in column A will vary. I need to know if any of the cells in column A is less than 1.
If there is one (or more) cell containing a value less than 1, I need a cell (A1 for example) to show NOT OK. If only ALL the cells' values are greater than 1, I need the cell (A1 for example) to show OK.
If all cells in column A have values greater than 1, I want to continue and check column B for the same thing. Otherwise I want to save and close the workbook and continue with next open workbook...also with vba code.
Any suggestions on how to write this in VBA? Maybe there is way other than If(AND...)?
Sub IfAnd()
IF(AND(A5>1,A4>1,A3>1,A2>1),"OK", "NOT OK")
End Sub
This code will solve all your columns and insert the data in THE FIRST ROW OF EACH COLUMN
Sub Problems()
Dim CurCol, LastRow, LastCol as Long
LastCol = Cells(2, Columns.Count).End(xlToLeft).Column
For CurCol = 1 to LastCol
LastRow = Cells(Rows.Count, CurCol).End(xlUp).Row
If WorksheetFunction.Min(Range(Cells(2, CurCol), Cells(LastRow, CurCol))) < 1 Then
Cells(1, CurCol).Value = "NOT OK"
Else
Cells(1, CurCol).Value = "OK"
End If
Next CurCol
End Sub
Here is a way of doing it without any worksheet functions.
Sub test()
Dim ws As Worksheet
Dim ce As Range
Dim sr, lr, lc As Integer
'worksheet you are working with
Set ws = ThisWorkbook.Sheets(1)
'column you are searching
Set ce = ws.Cells(ws.Rows.Count, 1)
'start row set to 2 so row 1 will contain output
Let sr = 2
'search only the last row
Let lr = ce.End(xlUp).Row
Let lc = ws.Cells(sr, ws.Columns.Count).End(xlToLeft).Column
For c = 1 To lc
For r = sr To lr
If ws.Cells(r, c).Value < 1 Then
ws.Cells(1, c).Value = "NOT OK"
GoTo NotOK
End If
Next r
ws.Cells(1, c).Value = "OK"
NotOK:
Set ce = ws.Cells(ws.Rows.Count, c+1)
Let lr = ce.End(xlUp).Row
Next c
End Sub
This should be faster and more efficient for large data sets. Especially if it is sorted smallest to largest.
Here you are:
=IF(MAX(A:A)<1)
If VBA is not required, here is a worksheet formula that should do the job, and will also ignore blanks and non-numeric entries:
This formula must be array-entered:
=IF(ISNUMBER(MATCH(TRUE,IF(ISNUMBER($A:$A),$A:$A)<1,0)),"NOT OK","OK")
If this formula must be located in A1, change the range references from $A:$A to $A$2:$A$1000 where 1000 represents the highest conceivable row number for the data.
To array-enter a formula, after entering
the formula into the cell or formula bar, hold down
< ctrl-shift > while hitting < enter >. If you did this
correctly, Excel will place braces {...} around the formula.
So, I'm trying to figure out how to write an Excel macro to populate Column C with either 3 or a 4 depending on the amount of numbers contained in Column B.
I have searched up and down for the right wording to this, but I keep coming up short.
Basically, I need the macro to look at the number of digits in Column B. If there are 12 digits then the number is a UPC, and if there are 13 then the number is an EAN. I then need the macro to populate Column C with a 3 for UPCs and a 4 for EANs. This needs to be for the entire range of rows in the spreadsheet.
Does anyone have any ideas? Thanks a lot in advance!
You don't need to use a dirty old loop, try this (much faster if you have lots of rows):
Sub HTH()
With Sheet1.Range("B1", Cells(Rows.Count, "B").End(xlUp)).Offset(, 1)
.Formula = "=IF(LEN(TRIM(B1))=12,3,IF(LEN(TRIM(B1))=13,4,""""))"
.Value = .Value
End With
End Sub
Or use a user defined function, which has the advantage of changing when the data in column B is updated.
Better yet just use a formula, you don't really need VBA.
Alternative VBA Method (looping the fast way):
Sub HTH()
Dim vArray As Variant
Dim lCnt As Long
With Range("B1", Cells(Rows.Count, "B").End(xlUp))
vArray = .Value
For lCnt = 1 To UBound(vArray, 1)
Select Case Len(Trim(vArray(lCnt, 1)))
Case 12: vArray(lCnt, 1) = 3
Case 13: vArray(lCnt, 1) = 4
Case Else:
End Select
Next lCnt
.Offset(, 1).Value = vArray
End With
End Sub
You can get the length of a cell's value by using Len() like this Len(Range("A1")) for example.
Now you just need to loop through your column and look at each value. If you look for the last used cell and loop only through that range your loop will be faster.
Here is how I would do it:
sub TestUPC()
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Dim rRng As Range
Set rRng = Range("B1:B" & LastRow)
For Each cell In rRng.Cells
If Len(Trim(cell))=12 then
cell.Offset(0, 1).Value = 3
ElseIf Len(Trim(cell))=13 then
cell.Offset(0, 1).Value = 4
End If
Next
End Sub
An in cell equation could look like this:
=IF(LEN(B1)=12,3,IF(LEN(B1)=13,4," "))
As suggested in the comments you might want to test for spaces depending on your data:
=IF(LEN(TRIM(A1))=12,3,IF(LEN(TRIM(A1))=13,4," "))