I have 2 columns in excel, A and B. In A I have percentages (rates) and in B integers numbers (years).
rating PD year
0.39% 3
0.88% 2
1.32% 17
0.88% 1
0.26% 15
0.17% 2
0.17% 2
0.59% 2
0.59% 2
Then I have a Table in which in column F I have years and in row I have text.
Like this (the table is much bigger and years go up to 30):
Rating
Year AAA AA+ AA AA-
1 0.003% 0.008% 0.018% 0.049%
2 0.016% 0.037% 0.074% 0.140%
3 0.041% 0.091% 0.172% 0.277%
4 0.085% 0.176% 0.318% 0.465%
5 0.150% 0.296% 0.514% 0.708%
And so on (the table is much bigger than this).
So I would need a function, or a shortcut, which, for a given rate in column A and a given year in column B, gives me, in column C, the corresponding rating (AAA,AA+,AA etc.).
In the table the rates are the maximum. So if I have A1=0.50% and B1=2, then I go to look at the table, year 2 and corresponding rate, which is 0.74% (and therefore AA), because AA+ is 0.37% and is too low.
In other words, AA+ and year 2 are all the rates between 0.16% and 0.37%. And AA with year 2 are all the rates between 0.37% and 0.74%.
Do you know how I could perform this task?
Thank you very much.
For the sake of code readability, I've used two custom-made functions, alongside the main procedure shown here. Otherwise it would be a huge code-dump.
Before you begin, you have to change/check these data fields.
The (blue) data table needs to be named "scores" (or changed inside code to your own name)
Same goes for the (green) grades table - to be named "grades" and start in F1
Last but not least, the code presumes these two tables are in a sheet called "Sheet1"
So all of this needs to be changed within the code, if the names do
not match!
Now to the procedure:
Option Explicit
Private Sub run_through_scores()
Dim scores As ListObject ' table from A1
Dim grades As ListObject ' table from F1
Set scores = Sheets("Sheet1").ListObjects("scores")
Set grades = Sheets("Sheet1").ListObjects("grades")
Dim cell As Range ' for "for" loop
Dim inrow As Long ' will store in which row the year is
Dim resultColumn As Integer ' will store in which column the percentage is
'for every cell in second column of scores table (except header)
For Each cell In scores.ListColumns(2).DataBodyRange
inrow = get_year(cell).Row - 1
' ^ returns Row where result was found, -1 to accoutn for header
'using our get_interval() function, _
determines in which column is the sought percentage
resultColumn = get_interval(cell.Offset(0, -1), inrow).Column
cell.Offset(0, 1) = Sheets("Sheet1").Cells(1, resultColumn)
'write result in Column C ^
Next cell
End Sub
And to the functions:
get_year()
returns a Range Object from the "grades" table, in which we found
the matching year from our "scores" table. If the desired year is not found, it returns the year closest to it (the last table row)
' Returns a Range (coordinates) for where to search in second table
Private Function get_year(ByVal year As Variant) As Range
Dim grades As ListObject ' table from F1
Set grades = Sheets("Sheet1").ListObjects("grades")
Dim testcell As Range
Set testcell = grades.ListColumns(1).DataBodyRange.Find(year, LookIn:=xlValues)
'if found
If Not testcell Is Nothing Then
Set get_year = testcell
Else
Dim tbl_last_row As Long 'if year not found, return last row
tbl_last_row = grades.ListColumns(1).DataBodyRange.Rows.Count
Set get_year = grades.ListColumns(1).Range(tbl_last_row)
End If
End Function
And the second function:
get_interval()
returns a Range Object from the "grades" table. It compares individual cell ranges and returns upon a) if the sought percent from "scores" is less or equal (<=) then current cell percent or b) if we went through all the cells, it returns the last cell
(because it must be higher, than the maximum of specified interval)
Private Function get_interval(ByVal what As Variant, ByVal inyear As Long) As Range
Dim grades As ListObject ' table from F1
Set grades = Sheets("Sheet1").ListObjects("grades")
Dim cell As Range
For Each cell In grades.ListRows(inyear).Range
'check for interval
If what <= cell And cell.Column <> 6 Then 'we don't want to check year column
Set get_interval = cell
Exit Function
End If
Next cell
' if we arrived here, at this stage the result will always be the last cell
Set get_interval = grades.ListRows(inyear).Range(, grades.ListColumns.Count)
End Function
Upon firing (invoking) the run_through_scores() procedure, we get the results as expected:
if you have any questions, please let me know :)
Related
The aim is to match two tables accroding to some specific words.
There are two tables each with 3 colums and rows(see pic).
The value A2 (table 1) are being searched range A(table 2 ). That search of this value in table 2 range A shall continue until either the value is found in table 2 range A or the loop stops when a certain Cell (e.g. A30) is reached.For case 1, if the value in table 1 A2 is found in range A in table 2, the second value (e.g.in A3 table 1) shall be taken to search for that value in table 2 range A and so on until a sertain cell is reached again.For case 2, if the value A2 (table1) cannot be found in the given range A (table2), the value in the next colum B2 shall be search for in range B(table 2) until a certain cell is reached. If this isnt successfull as well the next step is to look for the value of C2(table1) in range C(table2).
The issue is to get the do loops in the right positions so as to the search of the values (table 1) in table 2 starts always with the values in Range A (table 1) when that value ( table 1) is found.
Update: Where I am stuck is to get the multiple Do-loops right. I guess I need 3 do-loops and my problem is to get the 3rd. do-loop (the very inner one) which does the checking of the values between the tables to jump to the very first do-loop after the value in question (table1) has been found in table 1. In other word, when the value A1 in table 1 is found the do-loop goes one row further to A2 and starts again. If nothing is found in table 2, pick up the value in B2(table1) and search again but in range "B" table 2.
I have also tried to include the command "loop until" when a certain cell number e.g cells(10,1) is reached. I guess here is also a buck init.
Sub Import_Klicken()
Dim wp As Workbook
Dim ws As Workbook
Dim c As Long, r As Long, rng As Range
Dim w As Integer
Dim t As Integer
Set ws = Workbooks.Open("C:\Users\Yavuz\Desktop\a.xlsx")
Set wp = Workbooks.Open("C:\Users\Yavuz\Desktop\t.xlsx")
Do
w = w + 1
i = i + 1
t = 0
Do
t = t + 1
If ws.Sheets("Tabelle1").Cells(i, w).Value = wp.Sheets("Tabelle2").Cells(t, w).Value Then
wp.Sheets("Tabelle2").Cells(t, w).Copy
Exit Do
End If
Loop Until wp.Sheets("Tabelle2").Cells(t, w).Value = treu
i = 0
Loop
I'm trying to have a program that can read a range of cells which consist of 12 cells (let's say: P79, R79, T79, V79, X79, Z79, AB79, AD79, AF79, AH79, AJ79, AL79) and under those cells there are 6 cells (let's say: V81, X81, Z81, AB81, AD81, AF81), the program is looking for whether or not there are values typed in the cells within the described range.
The program should be able to read the cells from left to right on the top row and loop down to the bottom row and read that from right to left.
If all the cells in the top row have values in them, then the program breaks and doesn't read the values in the bottom row.
As the program reads the values from each cell it should create a table consisting of three columns (let's say: M88, N88, O88), the leftmost column should have the cell number (in order of cell as read by the program (whichever cell has a value first in the loop is given the number 1 and then the next cell to have a value is given number 2 etc.). The middle column should have whatever value is written in it's corresponding cell read from the range. The right column should have the value of whatever is to the right of each cell containing a value.
The first value to be read with a value should give the value "Left End" and the last value to read (whether or not it is the 12th cell to have a value in the top row or the leftmost cell to have a value in the bottom row) should give the value "Right end".
An example of what a row from the table could look like:
Cell # Cell Value Position/Left/Right
1 First Left End
This is the code I have so far:
Sub Code()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Integer, j As Integer, k As Integer
' First loop to compare a car to the rest after it
For i = 1 To 12
For j = i + 1 To 12
If Not IsEmpty(ws.Range("Cell_" & i)) And Not IsEmpty(ws.Range("Cell_" & j)) Then
ws.Range("B82").Offset(i).Value = j
Exit For
End If
Next j
Next i
' Loop backwards to find "Right End"
For k = 12 To 2 Step -1 '24 To 2
If Not IsEmpty(ws.Range("Cell_12")) Then
ws.Range("B82").Offset(12).Value = "Right End"
Exit For
' Has the "Right End" Follow when cars are left blank for lower row
ElseIf IsEmpty(ws.Range("Cell_" & k)) And Not IsEmpty(ws.Range("Cell_" & k - 1)) Then
ws.Range("B82").Offset(k - 1).Value = "Right End"
Exit For
End If
Next k
What I have here merely inserts a count into a cell range, what I'm trying to do is have my code actually read the cells in the range in the order I described and one at a time look at which cells have values written in them and look at which cells (with values in them) are to the right of any cell with a value and produce the table described above.
After reading your explanation, which was quite challenging I tried to recreate what you are asking.
I used cells A1:L1 with numbers 1 to 12. in the row below that A2:L2, some numbers have been added. with an if value <> "" you can see which cells contain a value.
In the second worksheet the table is made:
Sub test()
Dim a As Integer
Dim i As Integer
Dim name As String
ActiveWorkbook.Sheets(1).Activate
a = 1
For i = 1 To endcel
If Sheets(1).Range("a1").Offset(a, i - 1).Value <> "" Then
name = Sheets(1).Range("A1").Offset(a, i - 1).Value
Sheets(2).Activate
Sheets(2).Range("b2").Offset(i).Value = name
End If
Next i
End Sub
Does this help? You can adapt it a bit to your problem.
Good luck!
I am having two Sheets , sheet1 and sheet2.
I have a table with the weekno, delay , Ok, percenatage of Delay and Percentage of OK.
In sheet 1, i am looking for the column T, and Count the number of '1' in the column. Similarly i look for column U and Count the number of '0' in the column.
the Count value has to be filled in sheet2 of the table looking into the week. I have my week in the column AX of sheet1.
I used formula like Countif for calculating the number of 1 in both the column.
could someone guide me how we can do it in VBA, to Count the value in column and pasting the result in a table in another sheet.I am struck how to start with coding. This is my sheet1, i have to Count the number of 1 in column t and u
To solve this problem, we have to use a couple of loops. First, we have to do an outer loop to go through the week numbers in sheet2, then imbedded in that loop we have to look at each row in sheet1 to see if it matches the week from sheet2 and to see if column T = 1 and if column U = 0. The code creates a counter that increase T by one every time a row in T is equal to 1 and does the same for U every time a row in U = 0.
Sub test()
Dim col As Range
Dim row As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim T As Integer
Dim U As Integer
Dim wk As String
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
For Each col In sh2.Columns 'This loops through all populated columns in row one
If sh2.Cells(1, col.Column).Value = "" Then
Exit For
End If
wk = sh2.Cells(1, col.Column).Value
For Each rw In sh1.Rows
If sh1.Cells(rw.row, 50).Value = "" Then
Exit For
End If
If sh1.Cells(rw.row, 50) = wk And sh1.Cells(rw.row, 20) = 1 Then
T = T + 1
End If
If sh1.Cells(rw.row, 50) = wk And sh1.Cells(rw.row, 21) = 0 Then
U = U + 1
End If
Next rw
sh2.Cells(2, col.Column) = T 'put counters into 2nd and 3rd row under each week, you can adjust this to put the number in a different cell.
sh2.Cells(3, col.Column) = U
T = 0 'reset counters to start looking at next week.
U = 0
Next col
End Sub
For some reason I wasn't able to view the images that you just uploaded. You may have to adjust my code to adapt to the specifics of your excel file. It will be good VBA practice for you. My code assumes the sheet2 has the week numbers going across the columns without any blank cells in between them. The vba drops the code in the 2nd and 3rd row under the corresponding week number. You can change this by changing the code that is indicated in the comments.
32bit Excel 2013 / Win 7 64 bit
UDF asks user for two range inputs from the same table and a lookup value ie:
Public Function FindBfromA(A as Range,B as Range, IDValue as Integer)
For IDCheck = 1 to A.Count
IF A(IDCheck) = IDValue then
IDNum = IDCheck
Exit For
End if
Next IDCheck
FindBfromA = B(IDNum)
End Function
Formula is added into another column of the table, for example
=FindBfromA([A],[B],[#C])
'Where C is calculated via something
My issues is Ranges A & B become disjointed. Where A(IDCheck) and B(IDCheck) should belong to corresponding columns in the same table row, based on where my cursor is when calculating begins Range [B] will re-key
This then causes the formula to return the wrong value from the FindBfromA=B(IDNum) as A(IDNum){Row} <> B(IDNum){Row}
I couldn't reproduce the error in the workbook I created with the false data - in my company (private) workbook the function operates essentially the same way, but captures two 'B' values given two IDs and passes them to another function.
It's difficult to be sure without seeing your range selections, but the unreliable element of your code is the cell references. By using a single integer index, you are basically selecting the nth cell in the range rather than cell on row n. My suspicion is that range B is offset from range A by a number of rows. Let's say your two selections were A = "A1:A10" and B = "B2:B11" then A(3), for example, would be on row 3 but B(3) would be on row 4. The same would apply if Range A had more than one column.
To eliminate that risk, refer to the ranges by the row and column indexes, as in the code below. You'll note I've also change the data type of the IDValue to a variant as this prevent an error being thrown in your IDValue should ever be something like a String or Long. I've also looped through range A with a For Each loop on each cell to cater for the case that range A has more than one column.
Public Function FindBfromA(A As Range, B As Range, IDValue As Variant) As Variant
Dim cell As Range
For Each cell In A.Cells
If cell.Value2 = IDValue Then
FindBfromA = B.Cells(cell.Row, 1).Value2
Exit Function
End If
Next
End Function
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