I have 2 columns in my excel file, and I want to get the MIN/Max/Average of the price in the second row based of the information in the first column. i cannot use the normal function as there is 200,000 rows in my workbook.
I have done this before with different data that used the date in the first column now I wish to change it as i am not using date. I am getting errors in the fist if statement.
Sub Button1_Click()
Dim Rng As Range, Dn As Range, n As Long, c As Long, K As Variant
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Application.ScreenUpdating = False
For Each Dn In Rng
If Not .Exists(DateValue(Dn.Value)) Then
.Add DateValue(Dn.Value), Dn.Offset(, 1)
Else
Set .Item(DateValue(Dn.Value)) = Union(.Item(DateValue(Dn.Value)), Dn.Offset(, 1))
End If
Next
Range("E1:H1") = Array("Date", "Max", "Min", "Average")
c = 1
For Each K In .keys
c = c + 1
Cells(c, "E") = K
Cells(c, "F") = Application.Max(.Item(K))
Cells(c, "G") = Application.Min(.Item(K))
Cells(c, "H") = Application.Average(.Item(K))
Next K
End With
Application.ScreenUpdating = True
End Sub
MIN/Max/Average of the values in column 2 that relate to the values in column 1
The "normal" functions should be working properly regardless of how many rows of data you have.
For example, I just double-checked worksheet functions MIN, MAX, AVERAGE, MINIFS, MAXIFS and AVERAGEIFS calculated on a column of 200k rows and dependant on the value of another column, and I didn't have any problem (using Excel for Office 365).
Example:
"Average of Column B where Column A equals 2"
Worksheet function:
=AVERAGEIFS(B:B, A:A, 2)
VBA WorksheetFunction:
MsgBox Application.WorksheetFunction.AverageIfs(Range("B:B"), Range("A:A"), 2)
Perhaps you're using an older version of Excel?
As far as I know, all of Excel's functions/formulas will work properly up to the maximum number of rows/columns of that the version can handle (which is 1,048,576 rows by 16,384 columns since at least Excel 2007).
Related
I have a sheet with data in 2 columns, A and B:
--A-- --B--
Apple 57
Orange 62
Lime 45
Orange 58
Apple 57
What I want is, I need to search column A for duplicates, then if there are any, look for their value in column B. If they are different, I want to color the cell in column A to red, show the other value of that entry in column C, and show a message on how many indifferences there are. Something like this:
--A-- --B-- --C--
Apple 57
Orange 62 58
Lime 45
Orange 58 62
Apple 57
Please help me with this, I know how to compare the value in one column, but then don't know how to search for additional value for them in the other column.
Since i am still at learning process it may not be the best solution but it seems it is working
```
' inoG
Sub Solution()
Dim rows As Integer
rows = Range("a1").End(xlDown).Row 'Getting total row number
Dim dt As Variant
dt = Range("a1:c" & rows) 'data into array '
'forward search
For i = 1 To rows
For j = i + 1 To rows
If dt(i, 1) = dt(j, 1) And dt(i, 2) <> dt(j, 2) Then
dt(i, 3) = dt(j, 2)
GoTo Continue1
End If
Next j
Continue1:
Next i
'backward search
For i = rows To 1 Step -1
For j = i - 1 To 1 Step -1
If dt(i, 1) = dt(j, 1) And dt(i, 2) <> dt(j, 2) Then
dt(i, 3) = dt(j, 2)
GoTo Continue2
End If
Next j
Continue2:
Next i
'filling row C and Highlighting
For i = 1 To rows
If Not IsEmpty(dt(i, 3)) Then
Cells(i, 3) = dt(i, 3)
Range("A" & i).Interior.ColorIndex = 3
End If
Next i
'Final Message
Dim totdif As Integer
totdif = WorksheetFunction.CountA(Range("C1:C1" & rows))
MsgBox totdif
End Sub
My following solution used a helper column to rank the values in Column B per item in Column A using COUNTIFS function. Then I used a pivot table to show the average value of each rank for each item.
Presume you have following named ranges:
ListItem being your data in Column A;
ListValue being your data in Column B.
The formula in Cell C2 is:
=IF(COUNTIFS(ListItem,A2,ListValue,">"&B2)+1>1,"2nd Value","1st Value")
Change the cell references used to suit your case.
This solution will create an output table laying out all the unique items and then populate the two different values (if there are two) in two consecutive columns next to each item. For comparison purpose I think a pivot table is sufficient and quite efficient.
P.s. to create a pivot table, you just need to highlight the source table, go to Insert tab, and click the Pivot Table button to generate a pivot table. Set up the fields in the following way and you will have something similar to my example:
EDIT #2
If you want to show the second value in Column C for each item, here is a formula based approach.
In Cell C2 enter the following formula and drag it down:
=IFERROR(AGGREGATE(14,6,AGGREGATE(14,6,ListValue/(ListItem=A2),ROW($Z$1:INDEX($Z:$Z,COUNTIF(ListItem,A2))))/((AGGREGATE(14,6,ListValue/(ListItem=A2),ROW($Z$1:INDEX($Z:$Z,COUNTIF(ListItem,A2))))<>B2)),1),"")
The logic is to use ListValue/(ListItem=A2) to return a range of values for each item, then use AGGREGATE function to filter out all the errors, then use
AGGREGATE(14,6,ListValue/(ListItem=A2),ROW($Z$1:INDEX($Z:$Z,COUNTIF(ListItem,A2))))<>B2
to further filter the range to show the second value (which is different to the first value), then use AGGREGATE function again to return that value.
Let me know if you have any questions. Cheers :)
I think you can do this with formulas.
If you are concerned about users changing the formula, use a Table (and perhaps even protect the formula column, although this would require VBA code to allow expanding the table). That way the ranges will dynamically adjust to additions and deletions of data, and the users will not need to edit the formula:
With the table renamed Fruits, and the columns named as in the screenshot:
=IFERROR(AGGREGATE(14,6,1/(([#Fruit]=[Fruit])*([#Value]<>[Value]))*[Value],1),"")
Use Conditional Formatting to format the cells
EDIT:
I think the table approach would give you a better solution, but for a VBA approach I would use a Dictionary and a collection of the different values associated with the fruits.
Assuming your first column is named "Fruit" (or something you can use in Find, or even a known address), you can use the following to create a column of the alternate values for each item.
'Add reference to Microsoft Scripting Runtime
' or use late binding
Option Explicit
Sub diffs()
Dim myD As Dictionary
Dim vData As Variant
Dim rData As Range, C As Range
Dim wsSrc As Worksheet
Dim I As Long, V As Variant
Dim colVals As Collection
'Find the table
Set wsSrc = Worksheets("sheet2") 'or wherever
With wsSrc.Cells
Set C = .Find(what:="Fruit", after:=.Item(1, 1), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not C Is Nothing Then
With wsSrc
Set rData = .Range(C, .Cells(.Rows.Count, C.Column).End(xlUp)).Resize(columnsize:=3)
vData = rData
End With
Else
MsgBox "No data table"
Exit Sub
End If
End With
'Collect the data into a dictionary
'Max 2 different values per fruit
Set myD = New Dictionary
myD.CompareMode = TextCompare
For I = 2 To UBound(vData)
If Not myD.Exists(vData(I, 1)) Then
Set colVals = New Collection
colVals.Add Item:=vData(I, 2), Key:=CStr(vData(I, 2))
myD.Add Key:=vData(I, 1), Item:=colVals
Else
On Error Resume Next 'omit duplicate values
myD(vData(I, 1)).Add Item:=vData(I, 2), Key:=CStr(vData(I, 2))
On Error GoTo 0
End If
Next I
'Populate column 3
For I = 2 To UBound(vData, 1)
Set colVals = myD(vData(I, 1))
vData(I, 3) = ""
If colVals.Count > 1 Then
For Each V In colVals
If V <> vData(I, 2) Then vData(I, 3) = V
Next V
End If
Next I
Application.ScreenUpdating = False
With rData
.Clear
.Value = vData
For I = 2 To UBound(vData)
If vData(I, 3) <> "" Then
With rData.Cells(I, 1)
.Font.Color = vbWhite
.Font.Bold = True
.Interior.Color = vbRed
End With
End If
Next I
End With
End Sub
I have tried my best to search for the answer but can't get what I'm looking for. I'm very new to VBA so may be going wrong in several places here . . .
I'm creating a data formatter that processes data with a different numbers of records (rows) each time it is used. Data will be on non-active sheet. First row has headings. I've successfully used similar code to the code below to identify rows with certain data on it and clear the contents of other cells on that row.
The reason I refer to column E is because it is the only column that has data in every record. I then have to find the rows that have a value in column BU, then multiply that value by 20 and insert the result in column BX of the same row.
I keep getting Run-time Error 13 but don't understand as it's simply a number with 2 decimal places in cell BU, and currently there is nothing in BX.
Sub CalcTotalLTA()
Dim i As Variant
'counts the no. of rows in E and loops through all
For i = 1 To Sheets("Input").Range("E2", Sheets("Input").Range("E2").End(xlDown)).Rows.Count
'Identifies rows where columns BU has a value
If Sheets("Input").Cells(i, 73).Value <> "" Then
'calculate Total LTA
Sheets("Input").Cells(i, 76).Value = Sheets("Input").Cells(i, 73).Value * 20
End If
Next i
End Sub
You're most likely having an issue because Application.Sheets holds both sheet types, which are Charts and Worksheets. Application.Sheets does not have a .Range() property.
Replace all instances of Sheets() with Worksheets().
Worksheets("Input").Cells(i, 76).Value = Worksheets("Input").Cells(i, 73).Value * 20
Even better:
Dim ws as Worksheet
Set ws = Worksheets("Input")
..
ws.Cells(i,76).Value = ws.Cells(i,73).Value * 20
Exclude Header Row From Range
Public Function rngExcludeHeaders(rng As Range) As Range
Set rng = rng.Offset(1, 0).Resize(rng.rows.count - 1, rng.Columns.count)
Set rngExcludeHeaders = rng
End Function
usage:
Dim MyRange as Range
Set MyRange = rngExcludeHeaders(ws.UsedRange)
Thanks to input from #Adam Vincent and #Vityata, and some other research (the reason why I'm solving this myself, hope that's not bad etiquette) I've found the solution. Starting the index 'i' at 2 and adding 1 at the end avoids the header row text and includes the last row too:
Option Explicit
Sub CalcTotalLTA()
Dim i As Variant
Dim ws As Worksheet
Set ws = Worksheets("Input")
'counts the no. of rows in E and loops through all
For i = 2 To ws.Range("E2", ws.Range("E2").End(xlDown)).Rows.Count + 1
'Identifies rows where columns BU has a value
If ws.Cells(i, 73).Value <> "" Then
'calculate Total LTA
ws.Cells(i, 76).NumberFormat = "0.00"
ws.Cells(i, 76).Value = ws.Cells(i, 73).Value * 20
End If
Next i
End Sub
Try it like this:
Option Explicit
Sub CalcTotalLTA()
Dim i As Long
With Worksheets("Input")
For i = 1 To .Range("E2", .Range("E2").End(xlDown)).Row
If .Cells(i, 3) <> "" Then
.Cells(i, 6) = .Cells(i, 3) * 20
End If
Next i
End With
End Sub
This is what I have changed:
Adding Option Explicit on top
I have used With Worksheets("Input") to make your code more understandable.
Furthermore, I suppose you do not need Rows.Count but .Row
I have changed 76 and 73 to 3 and 6 to avoid some scrolling to the right, thus be careful when you use it over your workbook.
Removed .Value as far as it is the default one.
I have taken a code posted here somewhere and inserted an If statement that basically makes the sheet save every 10,000 loops. I read an advice somewhere that this stops excel from crashing completely. I am basically trying to match columns and finding duplicates by highlighting them/copying.
The issues is both columns that I am comparing have 100,000 rows each. I have been running the code for 4 hours now and it has only produced 1000 lines of matches... I am expecting at least 15,000 matches.
This time penalty is getting ridiculous, I am pretty sure there is a faster way to do it, but I am no expert in coding. :(
Sub Compare()
Dim Report As Worksheet
Dim i, j, z, colNum, vMatch As Integer
Dim lastRowA, lastRowB, lastRow, lastColumn As Integer
Dim ColumnUsage As String
Dim colA, colB, colC As String
Dim A, B, C As Variant
Set Report = Excel.ActiveSheet
vMatch = 1
'Select A and B Columns to compare
On Error Resume Next
Set A = Application.InputBox(Prompt:="Select column to compare", Title:="Column A", Type:=8)
If A Is Nothing Then Exit Sub
colA = Split(A(1).Address(1, 0), "$")(0)
Set B = Application.InputBox(Prompt:="Select column being searched", Title:="Column B", Type:=8)
If A Is Nothing Then Exit Sub
colB = Split(B(1).Address(1, 0), "$")(0)
'Select Column to show results
Set C = Application.InputBox("Select column to show results", "Results", Type:=8)
If C Is Nothing Then Exit Sub
colC = Split(C(1).Address(1, 0), "$")(0)
'Get Last Row
lastRowA = Report.Cells.Find("", Range(colA & 1), xlFormulas, xlByRows, xlPrevious).row - 1 ' Last row in column A
lastRowB = Report.Cells.Find("", Range(colB & 1), xlFormulas, xlByRows, xlPrevious).row - 1 ' Last row in column B
Application.ScreenUpdating = False
'***************************************************
For i = 3 To lastRowA 'change this NUMBER depending on which row the data starts
For j = 3 To lastRowB
z = j / 10000
If Report.Cells(i, A.Column).Value <> "" Then
If InStr(1, Report.Cells(j, B.Column).Value, Report.Cells(i, A.Column).Value, vbTextCompare) > 0 Then
vMatch = vMatch + 1
Report.Cells(i, A.Column).Interior.ColorIndex = 35 'Light green background
Range(colC & 1).Value = "Items Found"
Report.Cells(i, A.Column).Copy Destination:=Range(colC & vMatch)
If j = Int(j) Then
ThisWorkbook.Save
Exit For
Else
'Do Nothing
End If
End If
End If
Next j
Next i
If vMatch = 1 Then
MsgBox Prompt:="No Items Found", Buttons:=vbInformation
End If
'***************************************************
Application.ScreenUpdating = True
End Sub
Looking at your code... a few points:
Why not make A, B, C as string which hold the column you are looking at? This will increase performance. There is no need for the split and when you are looping instead of A.column you can just write A.
Are you trying to find complete matches (as oppose to a match in part of the text)? If so, set the values into a variable e.g. aValue = Report.Cells(j, A).Value and bValue = Report.Cells(j, B).Value and then compare them using if aValue = bValue then
Are you comparing one column against another, and then displaying results in a third column if there is a match in the SAME row? If so, what is the purpose of the j loop? Just loop through i (which will be your row) and compare value in both column A and column B.
If value can be on any row in the second column, then yes you can use the j loop, but an even faster way will be to use Excel in-built find function in VBA where you will search your value on column B:B. Using Excel Find in VBA is significantly faster.
What is z?
Worksheet save will only fail if bigger than the bounds of type Int. Is that what you want?
Your indentation needs to be corrected.
Exit For
Else
'Do Nothing
End If
Above needs to be indented 2-3 times
Implement the above improvements and let me know how you get on. Good luck.
I have data in column D.
There is a header in column D1 and numeric values in D2 downward. I would like to select all numeric values in column D (the number of values is unknown) and multiply them by -1 (replacing the current values in column D). How would I do this through VBA code?
If I could use formulas in Excel I would simply drag the formula D2*-1 downward; however, I need the VBA equivalent.
The following works almost instantaneously when tested with 100,000 random values:
Sub MultColDbyOne()
Dim i As Long, n As Long, A As Variant
n = Cells(Rows.Count, "D").End(xlUp).Row
A = Range(Cells(2, "D"), Cells(n, "D")).Value
For i = LBound(A) To UBound(A)
A(i, 1) = -A(i, 1)
Next i
Range(Cells(2, "D"), Cells(n, "D")).Value = A
End Sub
The sub works by first determining the last row with data in column D, then transferring it to a VBA array (which is, somewhat annoyingly, a 2-dimensional array with only 1 column), looping through that array replacing each number in it by its negative, then transferring it back. This Range to array then back to Range strategy is fairly common (and fairly efficient) in VBA.
Just for curiosity I wanted to employ selecting special cells (numbers) feature of Excel. I created another function and tested the speed against the function created by #John Coleman.
If column D contains 10,000 values, #John Coleman's function is faster.
If column D contains 1,000,000 values, this function is faster.
Sub ChangeSignColD()
Dim v, x As String
Application.ScreenUpdating = 0
x = Selection.Address
With Cells(1, 5)
v = .Value
.Value = -1
.Copy
Columns("D:D").SpecialCells(2, 1).PasteSpecial -4163, 4
.Value = v
End With
Range(x).Select
Application.CutCopyMode = 0
End Sub
In addition, I noticed that this function would not error if there was e.g. some text value in the column.
I like how #Zygd solve it, but i propose to use a cell for the -1 not interfering with existing working range.
Sub InvertNumericSign()
Dim LastCell As Range
Dim SignRng As Range
Set LastCell = Cells.SpecialCells(xlCellTypeLastCell)
Set SignRng = Selection
If Not LastCell = "" Then Set LastCell = LastCell(2, 2)
LastCell = -1
LastCell.Copy
SignRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
LastCell.ClearContents
End Sub
In Excel, I am trying to get a macro to move numbers with a "-".
I have a column E with a list of numbers
54525841-1
454152
1365466
1254566-1
1452577-1
I want a macro to move all the numbers that have a dash or hyphen at the end to column C.
So I would need E1 54525841-1 to be moved to C1.
You'll need to change "Sheet1" to the name of the sheet where your data is.
This looks through every cell (with data) in the E column and moves the value accross to the C column if it contains a dash.
Sub MoveDashes()
Dim Sheet As Worksheet
Dim Index As Long
Set Sheet = ThisWorkbook.Worksheets("Sheet1")
For Index = 1 To Sheet.Cells(Application.Rows.Count, "E").End(xlUp).Row
If InStr(1, Sheet.Cells(Index, "E"), "-") > 0 Then
Sheet.Cells(Index, "C") = Sheet.Cells(Index, "E").Value
Sheet.Cells(Index, "E").Value = ""
End If
Next
End Sub
Does it have to be a macro? How about Advanced Filter?
Your numbers are in column E. Let's assume they have a header.
E1: Number
E2: 54525841-1
E3: 454152
E4: 1365466
E5: 1254566-1
E6: 1452577-1
In a separate area of your worksheet (let's say column G) put the following criteria:
G1: Number
G2: *-*
Your advanced filter criteria would look like this:
Anything with a "-" in it will be copied to column C.
I got it to work by this:
Sub MoveDash()
x = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Range("E2:E" & x)
If InStr(Cell, "-") <> 0 Then
Cell.Offset(, 1) = Cell
Cell.ClearContents
End If
Next Cell
end sub
You can do this without VBA, but here is an efficient way to do it using the dictionary object.
Sub MoveNumbersWithDash()
Application.ScreenUpdating = False
Dim i As Long, lastRow As Long
Dim varray As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
lastRow = Range("E" & Rows.Count).End(xlUp).Row
varray = Range("E1:E" & lastRow).Value
For i = 1 To UBound(varray, 1)
If InStr(1, varray(i, 1), "-") <> 0 Then
dict.Add i, varray(i, 1)
End If
Next
Range("C1").Resize(dict.Count).Value = _
Application.WorksheetFunction.Transpose(dict.items)
Application.ScreenUpdating = True
End Sub
How it works:
The major theme here is avoiding calls to Excel (like a for each loop). This will make the function blazing fast (especially if you have tens and thousands of rows) and more efficient. First I locate the last cell used in E then dump the entire row into a variant array in one move. Then I loop through each element, checking if it contains a "-", if it does, I add it to a dictionary object. POINT: Add the entry as the ITEM, not KEY. This makes sure that we allow for duplicates. The variable I will be unique for each entry, so I use that as the key. Then I simple dump the entire array of cells with "-" into column C.
Why Dictionary?
The dictionary object is very fast and comes with 2 really great functions: .Keys and .Items. These will return an array of all the keys or items in the dictionary, which you can use the Transpose function on to dump an entire column of values into Excel in one step. Super efficient.