I have a dynamic table range of certain values (amounts). These amounts are generated into the table through a macro I've created.
What I want to do: Rank these amounts into the empty column by number.
eg. the cell in Column G next to 89k would be ranked as 1, one next to 77k would be 2 etc.
I also already have other functions defined, which I'm not going to explain here for readability reasons, but all you need to know: there are two variables obtained through functions
tbl_first = (int) Index of the ListRow of the first table item (so in this case it would be the row with 89k = 1st row so in this example 1)
tbl_last = (int) same as above, but indexes the last row (77k) in this example as 7
so my code is the following
' sets the tbl variable to the red table in the picture
Dim tbl As ListObject: Set tbl = Sheets("Summary").ListObjects("time_top")
Dim pos As Integer, diff as integer
diff = tbl_last - tbl_first
For j = tbl_first To tbl_last ' loops through all the added rows
For n = 1 to diff' indexing for the large function
' index the pos through the excel large function for our values (should return the k-th position from the largest value)
pos = Application.WorksheetFunction.Large(Range(Cells(tbl_first, 6), Cells(tbl_last, 6)), n)
With tbl.ListRows(1)
.Range(j, 6) = pos ' add the value to the column G to the right
End With
Next n
Next j
So the expected result would look like this:
I also keep getting the following error, which is caused by me incorrectly assigning the pos value.
Either way, probably multiple of things wrong here and much more elegant solution is out there, that just didn't hit me yet.
Think you need Rank (watch out for equal ranks). Large returns the nth largest value of a set.
Here is a simple example on a two column table which perhaps you can adapt. The rank is added in the second column.
Sub xx()
Dim tbl As ListObject: Set tbl = Sheets("Summary").ListObjects("time_top")
Dim r As Range
For Each r In tbl.ListColumns(1).DataBodyRange
r.Offset(, 1) = WorksheetFunction.Rank(r, tbl.ListColumns(1).DataBodyRange)
Next r
End Sub
Related
I have this pivot table I am inserting above my data. The data can be different lengths and so the pivot table and be different lengths. So what I do is put the data a little ways down on the sheet starting at say maybe row 30. Then I insert my pivot table up top. What I do next is I then have some code to delete all of the blank rows in between my data and the pivot table.
sub foo()
dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A1:Z50")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
This code will delete all of the blank rows and seems to work correctly. Since that puts everything together, what I want to do then is just put 2 blank rows in between my pivot table and my data but I don't know how to figure out where my pivot table ends or where my data begins.
So I want it to look like that ^^^^ , but right now Row 7 and 8 are not there and my data is pushed up onto my pivot table. Any help is appreciated please!
I was thinking someone like using Rows.Count + 1 or something to find where the pivot table ends. But I don't know how it would determine that since there is data in the row right after. SO maybe I need to find when there is data starting in say Column A then Insert the rows right before that. Thank you in advance for the help!
Try something along those lines:
Public Sub Answer()
Dim dataTopRowIndex As Integer
Dim ptBottomRowIndex As Integer
With ActiveSheet 'Note: use your worksheet's CodeName here instead, e.g. With Sheet1 (Active[anything], Activate, Select, Selection: evil).
dataTopRowIndex = .Cells(1, 1).End(xlDown).Row
With .PivotTables("PivotTable1").TableRange1 'Replace PivotTable1 by your PT's name.
ptBottomRowIndex = .Row + .Rows.Count - 1
End With
If (dataTopRowIndex - ptBottomRowIndex - 1) > 2 Then
.Range(.Rows(ptBottomRowIndex + 1), .Rows(dataTopRowIndex - 3)).EntireRow.Delete
End If
End With
End Sub
hopefully someone will be able to help me. I need to write a query, which would shrink the data from multiple columns (in my case from columns A:H) into one column.
The original file looks like this:
I need to shrink the data one by one by rows. I mean, the query has to check the first row and take the data (name), and put it into "a new column" then check the second column and do the same, and continue like this one by one. The table has 170 rows.
I found a query that is shrinking the data from multiple columns into one column but in another order than I need. The query is taking as first all data from a column A and putting it into "a new column", then taking all data from a column B and putting it into "a new column" under the data from the previous column (column A).
This is the query I tried to apply:
Please could somebody help me with it? I have to admit that I have not use UBound and LBound functions and I am getting pretty lost here. :(
I will be thankful for any advise how to adjust this query.
Many thanks in advance! :)
Try this. I'm first setting your range to an array. I then loop through the array and 'slice' each row using Application.Index. It then Joins all the content in that row together before Trimming the whitespace left over from either end. This leaves me with the one value in my results array (tmp). The code then clears your source data before leaving all your data in one column.
Sub CombineColumns()
Dim rng As Range
Dim tmp As Variant, vaCells As Variant
Dim i As Long
Set rng = Sheets("DATA").Range("A2:H200")
vaCells = rng.Value2
ReDim tmp(LBound(vaCells) To UBound(vaCells))
For i = LBound(tmp) To UBound(tmp)
tmp(i) = Trim(Join(Application.Index(vaCells, i, 0)))
Next i
With rng
.ClearContents
.Cells(1).Resize(UBound(tmp)).Value2 = Application.Transpose(tmp)
End With
End Sub
LBound returns the lowest position in the array (usually 0 or 1) and UBound returns the highest
I think something like this
for i = 1 to 170
for y = 1 to 8
if worksheets("trainers").cells(i,y).value <> "" then
worksheets("output").cells(i,1).value = worksheets("trainers").cells(i,y).value
exit for
end if
next y
next i
or on same sheet
For i = 1 To 170
Z = 0
For y = 1 To 8
If Cells(i, y).Value = "" Then
Cells(i, y).Delete Shift:=xlToLeft
Z = Z + 1
If Z <= 8 Then y = y - 1
End If
Next y
Next i
I cannot get this function to return my values to the output column in excel:
To overcome some intense lookup tables and speed up computation, I am using a pivot table with slicers to output row numbers from filtering. These rows then need to be converted into a column of true/false cells for a large table from which I then want to perform more calculations. To avoid lookups or matching I simply need to step through the list of rows and turn those cells to "true" in the output vector.
Function IncludedinSlicer(input_range As Variant) As Variant
Dim n As Long, j As Long, r As Long
n = input_range.Height ' Height of the column of reference values
' every row in the input_range contains a row number which in the output should be TRUE
' all other rows should be false
Dim output_range As Variant
ReDim output_range(1 To 300000)
' This covers the maximum number of rows
' Initialise all rows to FALSE
For j = 1 To 300000
output_range(j) = False
Next j
' Set only those rows listed in the reference to TRUE
For j = 1 To n
r = input_range(j).Value
If r = 0 Then ' If r=0 then we are beyond the end of the reference table and have captured some blank rows
Exit For ' Exit, to avoid outside-of-array errors
Else
output_range(r) = True
End If
'End If
Next j
' Return results to Excel
' THIS LAST BIT DOES NOT RETURN VALUES TO EXCEL
IncludedinSlicer = output_range
End Function
I know this should be trivial but somehow it has vexed me for literally hours. Please help! Thank you in advance!
EDIT: Found the issue!
First, thank you for pointing out the difference between Height and Rows.Count as I was not aware of this.
Unfortunately, that still left me with the same error in the final cell output (#Value). Luckily in the meantime I tried processing this via Matlab instead and when passing back the results I got the same error. This allowed me to narrow down the problem and I tracked the error to ... (drum roll) ... VBA's 2^16 limit for array size.
My table has close to 2^18 rows so this causes the error.
input_range.Height refers to the literal height in pixels of the range. Try instead input_range.Rows.Count to get the number of rows in the range.
For your function, you should be passing in (and potentially returning) a Range type instead of the ambiguous Variant type.
This will give you direct access to all of the properties of the Range type (i.e. Rows, Columns, Cells) and would probably make it easier to catch your issue that bobajob pointed out.
Currently I have a worksheet which has different colored cells in it like the one below:
[currentsheet] http://imgur.com/na6nvNH
I am using an array to count the colored cells per column. Here is my a snippet of my code:
Dim difference(0 To 41) As Long
For Each mycell In ActiveWorkbook.Worksheets("Differences").UsedRange
Dim col As Long
col = mycell.Column
If ActiveWorkbook.Worksheets("Differences").Cells(mycell.Row,mycell.Column).Interior.Color = vbRed Then
difference(col) = difference(col) + 1
End If
Next mycell
Sheets("Summary").Cells(47, 3) = difference(0)
Sheets("Summary").Cells(48, 3) = difference(1)
Sheets("Summary").Cells(49, 3) = difference(2)
etc.
Which will list the amount of colored cells I have per column. I need help breaking this down so I can create a table which shows the number of colored cells per department. I have no idea on how to do this!
To make it easier to view I am looking to create this:
[FinalSheet] http://imgur.com/i6W60m7
I should add: the amount of rows within the sheet can vary, they can also vary per department
Tried applying a column filter beginning with the first department and then counting the colored cells once the filter was applied, however since I am looking at every cell in the code above the result is still per column.
For anyone looking for an answer to this, a rather long method. However, I applied a filter and then set the range to only the visible cells instead of the used range in the whole worksheet
It seems it would be a lot easier to use a multi dimensional array, so you would have Array(4,7) so some sudo code might look like. I could do real code, but you seem to know what your doing.
Select Case mycell.row
Case 1
Array(1,Col) = Array(1,Col) + 1
Case 2
Array(1,Col) = Array(1,Col) + 1
Case 3
Array(2,Col) = Array(2,Col) + 1
end select
The trick to a multi dimensional array is to think of it like a spread sheet, (2,2) = 3 rows, by 3 columns ... (3 because arrays start at 0) The beauty of it is, if you do it this way when it comes to extract the data you simply put a double loop
For I =0 to Ubound(Array)
For II = 0 to Ubound(Array,2)
Cell(I,II).Value = Array(I,II)
next
next
I'm new to vba and have got help here earlier with some issues I had with vba macros, now I need help again.
I have an excel file with tons of data and I have huge amounts of duplicate EAN numbers in column S, I want to delete all duplicate EANs (the entire rows with the duplicates) but keep the one with lowest price (column Q), so I want to compare duplicate EANs from column S and delete all duplicates based on the lowest prices in column Q and keep the cheapest one. It's alot of data, more than 10000 rows, so do this manually by a formel is not the best way, takes alot of time to delete this rows manually.
example below (the first is price and second should be an ean):
104,93 - 000000001
104.06 - 000000001
104.94 - 000000001
in this case I want to delete first and third row and keep the second, anyone knows how the macro should look like, i use Excel 2010 ?
This might help you.
I assume you have a Header row. If not, change iHeaderRowIndex to 0 .
The first part creates a dictionary object, collects all the unique EAN numbers, and for each EAN it assigns a very high price (10 million)
Then it rescans the list, this time does a "MIN" logic to determine the lowest price per EAN.
Another rescan, this time it puts a MIN mark in a free column next to each min EAN (you should choose a name of a free and empty column - I put in "W" but you can change that)
Last, it rescans the list, in reverse order, to delete all the lines that do not have the MIN mark. Also, at the end, it deletes the column with the MIN marks.
Public Sub DoDelete()
Dim oWS As Worksheet
Dim d As Object, k As Object
Dim a As Range
Dim b As Range
Dim sColumnForMarking As String
Dim iHeaderRowIndex As Integer
Dim i As Integer
Dim iRowsCount As Integer
Dim v As Double
Set oWS = ActiveSheet
Set d = CreateObject("scripting.dictionary")
' ----> Put here ZERO if you do not have a header row !!!
iHeaderRowIndex = 1
' ----> Change this to what ever you like. This will be used to mark the minimum value.
sColumnForMarking = "W"
' Selecting the column "S"
Set a = _
oWS.Range(oWS.Cells(1 + iHeaderRowIndex, "S"), _
oWS.Cells(ActiveSheet.UsedRange.Rows.Count, "S"))
' putting a high number, one that is beyond the max value in column Q
' ----> Change it if it is too low !!!!
For Each b In a
d(b.Text) = 9999999 ' very high number, A max++ to all the prices
Next
For Each b In a
v = CDbl(oWS.Cells(b.Row, "Q").Value)
If v < CDbl(d(b.Text)) Then
d(b.Text) = v
End If
Next
For Each b In a
v = CDbl(oWS.Cells(b.Row, "Q").Value)
If v = CDbl(d(b.Text)) Then
oWS.Cells(b.Row, sColumnForMarking).Value = "MIN"
End If
Next
' This part deletes the lines that are not marked as "MIN".
iRowsCount = oWS.UsedRange.Rows.Count
Application.ScreenUpdating = False
For i = iRowsCount To iHeaderRowIndex + 1 Step -1
If oWS.Cells(i, sColumnForMarking).Text <> "MIN" Then
oWS.Rows(i).Delete Shift:=xlShiftUp
End If
Next
' clean up- deletes the mark column
oWS.Columns(sColumnForMarking).EntireColumn.Delete
Application.ScreenUpdating = True
End Sub