In excel, I have column 1 with tickers, and column 2 with numbers, like this:
A B
1 AAA 10
2 AAA 12
3 AAA 14
4 BBB 9
5 BBB 10
6 BBB 11
I need a piece of code to calculate average BY TICKER, which means that in this case I would have AAA average : 12 and BBB average = 10, etc etc etc. Up to now all i got is this code which tries to calculate the sums, I will do the divisions later, but something's wrong:
For row = 2 to 6
Ticker = Cells(row - 1, 1)
If Cells(row, 1) = Cells(row - 1, 1) Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
row = row + 1
Next
I get an error saying "For is missing"
Maybe something like this in C1.
=IF(A1<>A2,AVERAGEIF(A:A,A1,B:B),"")
In your code:
sum ignored the first AAA
missed the End If
incremented row twice, once by row = row+1 and then by next
and some other not used variables
Try this:
Prev = "***"
For row = 1 to 6
If Cells(row, 1) = prev Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
End If
prev = Cells(row,1)
Next
To extend the answer from Jeeped and do it with a list which is not ordered, you also could do it like this:
C1: =A1
C2: =IF(LEN(C1),IFERROR(INDEX(A:A,MATCH(1,(COUNTIF(C$1:C1,A$1:A$1000)=0)*(A$1:A$1000<>""),0)),""),"")}
C3....Cn: copy down from C2
D1: =IF(LEN(C1),AVERAGEIF(A:A,C1,B:B),"")
D2...Dn: copy down from D1
C2 is an array formula and needs to be confirmed with Ctrl+Shift+Enter
to do it via VBA (should be faster than my formula for really big tables) you can use something like that: (put this in a "Module" in the VBA-Window, the same like your recorded macros ar written)
Option Explicit
Public Function getAllAvg(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
j = 1
While Len(varOutput(j, 1)) And (varOutput(j, 1) <> varInput(i, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
varOutput(j + 1, 1) = ""
End If
End If
Next
While Len(varOutput(j, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
For i = j To UBound(varOutput)
varOutput(i, 1) = ""
varOutput(i, 2) = ""
Next
End If
getAllAvg = varOutput
End Function
then select a range like C2:D12 and enter:
=getAllAvg(A:B)
and confirm with Ctrl+Shift+Enter. it will directly output the whole list (and recalculate if needed)
EDIT:
If your list is always in a sorted order, you also could use this code:
Option Explicit
Public Function getAllAvgSorted(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
j = 1
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
If varOutput(j, 1) <> varInput(i, 1) Then
If Len(varOutput(j, 1)) Then j = j + 1
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
End If
End If
Next
While j < UBound(varOutput)
j = j + 1
varOutput(j, 1) = ""
varOutput(j, 2) = ""
Wend
getAllAvgSorted = varOutput
End Function
Related
I have a list of 1000+ names in a single column in excel where the names repeat occasionally. I am trying to count how many times each name occurs. This is what I have currently and it populates the desired sheet but it seems to mess up when counting the number of times the names show up. Anything helps!
m = 2
n = 1
person = Worksheets("Sheet1").Cells(m, 6).Value
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
For i = 0 To Total_Tickets
person = Worksheets("Sheet1").Cells(m, 6).Value
y = 1
d = 0
Do While d <= i
comp = Worksheets("Sorted_Data").Cells(y, 2).Value
x = StrComp(person, comp, vbTextCompare)
If x = 0 Then
Worksheets("Sorted_Data").Cells(n - 1, 3).Value = Worksheets("Sorted_Data").Cells(n - 1, 3).Value + 1
m = m + 1
d = 10000
ElseIf x = 1 Or x = -1 Then
If comp = "" Then
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
d = 10000
End If
y = y + 1
d = d + 1
End If
Loop
Next i
You're managing a lot of counters there, and that makes the logic more difficult to follow.
You could consider something like this instead:
Sub Tester()
Dim wsData As Worksheet, wsList As Worksheet, arr, m, i As Long, nm
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsList = ThisWorkbook.Sheets("Sorted_Data")
'grab all the names in an array
arr = wsData.Range("A2:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row).Value
For i = 1 To UBound(arr, 1) 'loop over the array
nm = arr(i, 1) 'grab the name
m = Application.Match(nm, wsList.Columns("A"), 0) 'existing name on the summary sheet?
If IsError(m) Then
'name was not found: add it to the summary sheet
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = nm
m = .Row
End With
End If
With wsList.Cells(m, "B")
.Value = .Value + 1 'update the count
End With
Next i
End Sub
I want to sort below Two-digit array by VBA code
A 1
B 2
A 1
C 3
or below:
1 A
2 B
1 A
3 C
I have tried to sort them by Dictionary, but, Dictionary is not allowed to insert duplate key.
Is there any want to sort above array by number 1,2,3
I made this some time ago, it might help.
Function ArraySorter(ByVal RecArray As Variant, Optional ByVal RefCol As Integer = 0) As Variant
Dim Menor As String
Dim NewArray() As Variant
Dim i As Double, j As Double
Dim menorIndex As Double
Dim NewArrayIndex() As Double
Dim UsedIndex() As Double
ReDim NewArrayIndex(UBound(RecArray, 2))
ReDim NewArray(UBound(RecArray), UBound(RecArray, 2))
For i = 0 To UBound(NewArrayIndex)
NewArrayIndex(i) = -1
Next i
UsedIndex = NewArrayIndex
For i = 0 To UBound(RecArray, 2)
Menor = ""
menorIndex = -1
For j = 0 To UBound(RecArray, 2)
If UsedIndex(j) = -1 Then
If Menor = "" Then
Menor = RecArray(RefCol, j)
menorIndex = j
Else
If RecArray(RefCol, j) < Menor Then
Menor = RecArray(RefCol, j)
menorIndex = j
End If
End If
End If
Next j
UsedIndex(menorIndex) = 1
NewArrayIndex(i) = menorIndex
Next i
For i = 0 To UBound(NewArrayIndex)
For j = 0 To UBound(NewArray)
NewArray(j, i) = RecArray(j, NewArrayIndex(i))
Next j
Next i
ArraySorter = NewArray
End Function
If you have something like:
Function testArraySorter()
Dim myArr() As Variant
ReDim myArr(1, 3)
myArr(0, 0) = "A"
myArr(0, 1) = "B"
myArr(0, 2) = "A"
myArr(0, 3) = "C"
myArr(1, 0) = 1
myArr(1, 1) = 2
myArr(1, 2) = 1
myArr(1, 3) = 3
myArr = ArraySorter(myArr)
For i = 0 To UBound(myArr, 2)
Debug.Print myArr(0, i), myArr(1, i)
Next i
End Function
you'll get this in your immediate verification :
A 1
A 1
B 2
C 3
If you need to sort based in two or more columns, you could add a dummy column into your array, concatenate the criteria columns into it and then set this dummy column as RefCol: myArr = ArraySorter(myArr, addedColNumberHere).
Hope this helps.
I solved it on my own. I added a for loop. Here is my working code. Thanks to everyone else for trying to help.
Sub runMatch()
Dim critRemID, listRemID, critRemIDstart, listRemIDstart As Range
Set critRemID = Worksheets("Enterprise - score").Cells(2, 1)
Set listRemID = Worksheets("Sheet1").Cells(2, 1)
Set critRemIDstart = Worksheets("Enterprise - score").Cells(2, 30)
Set listRemIDstart = Worksheets("Sheet1").Cells(2, 2)
Dim i, j, index As Integer
i = 0
j = 0
Do While critRemID.Offset(i, 0) <> ""
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
For index = 0 To 84
critRemIDstart.Offset(i, index) = listRemIDstart.Offset(j, index).Value
Next index
i = i + 1
j = 0
index = 0
Else
If listRemID.Offset(j, 0) = "" Then
j = 0
i = i + 1
Else
j = j + 1
End If
End If
Loop
End Sub
I have two sheets, they each have a the same IDs on each sheet but
different sets of data.
I want to scan through the rows of data and if there is a match, copy
the entire row from a certain column to another certain column to the
end of one of the sheets.
Sheet 1 is the sheet I want to copy info into, on the end I've created
the same headers for the data I want to bring over from sheet 2.
the code below is what I have, I set a range up for the IDs and one
for where I want the copied cells to start
Dim critRemID, listRemID, critRemIDstart, listRemIDstart As Range
Set critRemID = Worksheets("Enterprise - score").Cells(2, 1)
Set listRemID = Worksheets("Sheet1").Cells(2, 1)
Set critRemIDstart = Worksheets("Enterprise - score").Cells(2, 30)
Set listRemIDstart = Worksheets("Sheet1").Cells(2, 90)
Dim i, j As Integer
i = 0
j = 0
Do While critRemID.Offset(i, 0) <> ""
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Row(i) = listRemIDstart.Row(j).Value
i = i + 1
j = 0
Else
j = j + 1
End If
Loop
I keep getting this error
Wrong number of arguments or invalid property assignment
I tried going a different route but kept getting confused as shown
below. I was trying to have it copy each cell one by one and once it
reached an empty cell, it would move onto the next ID on the main
sheet and start over but this does nothing, I think it keeps
increasing both IDs on the sheet and never finds a match.
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Offset(i, k) = listRemIDstart.Offset(j, l).Value
k = k + 1
l = l + 1
Else
If listRemIDstart.Offset(j, l) = "" Then
j = j + 1
l = 0
i = i + 1
k = 0
Else
j = j + 1
i = i + 1
l = 0
k = 0
End If
End if
any help is appreciated. Thanks.
Range.Find method could find the key easily.
Dim critRem, listRem As Worksheet
Set critRem = Worksheets("Enterprise - score")
Set listRem = Worksheets("Sheet1")
Dim critRemID, listRemID, cell, matchedCell As Range
With critRem
Set critRemID = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With listRem
Set listRemID = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each cell In critRemID
Set matchedCell = listRemID.Find(cell.Value)
If matchedCell Is Nothing Then 'ID is not found
'Do nothing
Else 'ID is found, matchedCell is pointed to column A now
cell.Offset(0, 29).Resize(1, 10) = matchedCell.Offset(0, 89).Resize(1, 10)
'offset(0,29) means offsetting right 29 columns
'resize(0,10) means resizing the range with 1 row and 10 columns width
'feel free to change the number for your data
End If
Next cell
Note: If you are confused about offset().resize(), there is another approach. cell.Row gives you the row that the data should be written into, and matchedCell.Row gives you the row that the ID matched. So you can access certain cell by something like listRem.Range("D" & matchedCell.Row)
Tried to do it using the loop.
Sub Anser()
Dim critRemID As Range
Dim listRemID As Range
Dim critRemIDstart As Range
Dim listRemIDstart As Range
'::::Change Sheet names and column numbers:::::
Set critRemID = Worksheets("Sheet1").Cells(2, 1)
Set listRemID = Worksheets("Sheet2").Cells(2, 1)
Set critRemIDstart = Worksheets("Sheet1").Cells(2, 2)
Set listRemIDstart = Worksheets("Sheet2").Cells(2, 2)
Dim i, j As Integer
i = 0
j = 0
Do
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Offset(i) = listRemIDstart.Offset(j)
i = i + 1
j = 0
Else
j = j + 1
End If
Loop While critRemID.Offset(i, 0) <> ""
End Sub
If as you say both sheets have the same IDs, then why not use a Vlookup function to bring the data into Sheet1, then simply copy the results and paste as values so you get rid of the formula on them cells?
Something like a loop running:
For i = 1 to LastRow
Sheet1.cells(i, YourColumnNumber).value = "=VLOOKUP(RC[-1], Sheet2!R1:R1048576, 3, False)"
Next i
Sub MultipleSearch()
Dim aNum(), aTabl(), aRes()
Dim i As Long, k As Long, n As Long
With Worksheets("List1")
i = .Cells(.Rows.Count, "A").End(xlUp).Row
aTabl = .Range("A1:G" & i).Value
End With
With Worksheets("List2")
i = .Cells(.Rows.Count, "D").End(xlUp).Row
aNum = .Range("D1:D" & i).Value
ReDim aRes(1 To i + 3, 1 To 1)
aRes(1, 1) = .Range("K1").Value
End With
For i = 2 To UBound(aNum)
n = i
For k = 2 To UBound(aTabl)
If aTabl(k, 1) <> Empty Then
If aNum(i, 1) = aTabl(k, 1) Then
aRes(n, 1) = aTabl(k, 7): n = n + 1
End If
End If
Next k
Next i
Worksheets("List2").Range("K1").Resize(UBound(aRes), 1).Value = aRes
End Sub
Hi. I have a code that lookup value on Picture 1 in 4.column and value on Picture 2 in 1.column and when it matches it returns value from Picture 2. from 8.column as you see.
I need to make a change. I need to return value from 8.column in other way.
When its the first match of 26054112 i need to return the first number from 8.column - -10629425,25
When its second match of 26054112 i need to return the second number - -1549761,31
And so on...
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub