Right now I have a working formula
=IF(OR(COUNTIF(C2,"*"&$O$2:$O$13&"*")), "Yes", "")
It prints "Yes" if a string in column C matches a string in a list in column O.
However, I now have 2 lists, list A and list B, and now I need to be able to print "No" if a cell in column C matches any of the strings in list B, and if in neither list A or B, to print something like "NA".
I haven't been able to figure out the formula further than just the one list. Any help is appreciated.
I threw together a painfully simple version of what I am getting at, where "Jersey Color" is being populated by the formula, and "Team Red/Blue" are the lists.
Use below formula in B2 cell.
=IF(ISNUMBER(MATCH(A2,C:C,0)),"RED",IF(ISNUMBER(MATCH(A2,D:D,0)),"BLUE","NA"))
This loops through all the players and finds if they are matched to a team.
Cells.Clear
'data
For i = 1 To 20
Cells(i, 1) = Chr(64 + i)
Next i
For i = 1 To 20 Step 4
Cells((i + 3) / 4, 3) = Chr(64 + i + Int(Rnd * 2))
Cells((i + 3) / 4, 4) = Chr(66 + i + Int(Rnd * 2))
Next i
'code
Dim Players As Range, TeamA As Range, TeamB As Range
Set Players = Range("A1:A20")
Set TeamA = Range("C1:C5")
Set TeamB = Range("D1:D5")
Players.Offset(0, 1) = "N/A"
Players.Offset(0, 1).Font.Bold = True
Dim member As Range, player As Range
For Each player In Players
For Each member In TeamA
If member = player Then
player.Offset(0, 1).Interior.Color = RGB(255, 100, 100)
player.Offset(0, 1) = "RED"
End If
Next member
For Each member In TeamB
If member = player Then
player.Offset(0, 1).Interior.Color = RGB(100, 100, 255)
player.Offset(0, 1) = "BLUE"
End If
Next member
Next player
Output:
Related
I have Location data (latitude and longitude) of 1000's of locations and need to compute the distance between each of them taken two combinations at a time.
Example:
Let's just say I have four location data (latitude and longitude data) and want to compute the distance between them
Location Latitude Longitude
1. New York(L1) 40.7128° N 74.0060° W
2. Paris(L2) 48.8566° N 2.3522° E
3. London(L3) 51.5074° N 0.1278° W
4. Moscow(L4) 55.7558° N 37.6173° E
Need to calculate the distance between possible combinations i.e distance between L1&L2, L1&L3, L1&L4, L2&L3, L2&L4 and L3&L4
Excel Formula I'm using to compute distance is
=ACOS(COS(RADIANS(90-Lat1)) *COS(RADIANS(90-Lat2)) +SIN(RADIANS(90-Lat1)) *SIN(RADIANS(90-Lat2)) *COS(RADIANS(Long1-Long2))) *6371
How can I calculate it for large data set say 100's or 1000's of locations?
Alternatively, you can create a VBA function and then loop through your table.
Add this code to a Module in the VBA editor:
Public Function DistBetweenCoord(Lat1 As Double, Long1 As Double, Lat2 As Double, Long2 As Double)
'Cell Formula
'ACOS(COS(RADIANS(90-Lat1)) *COS(RADIANS(90-Lat2)) +SIN(RADIANS(90-Lat1)) *SIN(RADIANS(90-Lat2)) *COS(RADIANS(Long1-Long2))) *6371
With WorksheetFunction
A = Cos(.Radians(90 - Lat1))
B = Cos(.Radians(90 - Lat2))
C = Sin(.Radians(90 - Lat1))
D = Sin(.Radians(90 - Lat2))
E = Cos(.Radians(Long1 - Long2))
DistBetweenCoord = .Acos(A * B + C * D * E) * 6371
End With
End Function
Now you can access this through code or in cell. Here is an example of in-cell:
=DistBetweenCoord(C1,D1,C2,D2)
Here is how to loop through all possible combinations in another Sub. Output is in immediate window.
Sub CalcAllDistances()
With Worksheets("Sheet1")
For i = 1 To 4
For j = i To 4
If i <> j Then
Debug.Print .Cells(i, 2) & " to " & .Cells(j, 2) & ": " & DistBetweenCoord(.Cells(i, 3), .Cells(i, 4), .Cells(j, 3), .Cells(j, 4))
End If
Next j
Next i
End With
End Sub
EDIT - To change output to Sheet2 try the following:
Sub CalcAllDistances()
Dim wks_Output As Worksheet
Set wks_Output = Worksheets("Sheet2")
Dim OutputRow As Long: OutputRow = 1
With Worksheets("Sheet1")
For i = 1 To 4
For j = i To 4
If i <> j Then
wks_Output.Cells(OutputRow, 1).Value = .Cells(i, 2) & " to " & .Cells(j, 2)
wks_Output.Cells(OutputRow, 2).Value = DistBetweenCoord(.Cells(i, 3), .Cells(i, 4), .Cells(j, 3), .Cells(j, 4))
OutputRow = OutputRow + 1
End If
Next j
Next i
End With
End Sub
I would use a matrix.
Create a sheet (like 'GeocodeList' or something) for the geocodes, like your city|lat|lon in the question. Then create a sheet (like 'Distances') for a matrix, where the column and row labels are the city names. Then you can parameter your excel formula using V.LOOKUPs that look up exact codes from GeocodeList.
The formula would look like this (X is row number, Y is column letter.):
=ACOS(COS(RADIANS(90-VLOOKUP($A(X); GEOCODETABLE, LATCOLINDEX, 0)))
*COS(RADIANS(90-VLOOKUP((Y)$1; GEOCODETABLE; LATCOLINDEX, 0)))
+SIN(RADIANS(90-VLOOKUP($A(X); GEOCODETABLE, LATCOLINDEX, 0)))
*SIN(RADIANS(90-VLOOKUP((Y)$1; GEOCODETABLE; LATCOLINDEX, 0)))
*COS(RADIANS(VLOOKUP($A(X); GEOCODETABLE, LATCOLINDEX, 0)-VLOOKUP((Y)$1; GEOCODETABLE; LONCOLINDEX, 0))))
*6371
So basically the VLOOKUP automatically fetches your parameters, and you can extend the formula for the whole matrix.
I am attempting to create an Auto-grading test of sorts in Excel.
I have 5 values in Sheet1 that are input by a user in cells E5:E9. These should then be compared against a range of 5 more cells in Sheet2 (also cells E5:E9).
As the user might not always list these entries in the same order that I have in my Sheet2 range, I decided that I should loop through the range for each cell's input.
The next step would be to be able to ignore the value in the range once a match has been found but I need to get this part working correctly. Currently, the values absolutely match. However, I am not getting the correct output.
Sub Q1()
Dim i As Integer
For i = 5 To 9
If (Sheet1.Cells(5, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(6, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(7, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(8, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(9, 5) = Sheet2.Cells(i, 5)) Then
Sheet1.Cells(5, 6) = 1
Exit For
Else
Sheet1.Cells(5, 6) = 0
End If
Next
End Sub
I would expect the output of 1 to Sheet1 cell E6 but I am currently getting 0. Thanks!
Little Complex :)
Sub Q1()
Dim i As Integer
Dim j As Integer
Dim chck(5 To 9) As Boolean
For i = 5 To 9
For j = 5 To 9
If Sheet1.Cells(i, 5) = Sheet2.Cells(j, 5) Then
chck(i) = True
Exit For
Else: chck(i) = False
End If
Next
Next
j = 0
For i = LBound(chck) To UBound(chck)
If chck(i) = True Then j = j + 1
Next
If j = 5 Then
Sheet1.Cells(5, 6) = 1
Else: Sheet1.Cells(5, 6) = 0
End If
End Sub
Does this really need to be VBA? A formula can perform this calculation. Use this in 'Sheet1' cell F5:
=--(SUMPRODUCT(COUNTIF(Sheet2!E5:E9,E5:E9))>0)
If at least one of the values in 'Sheet1'!E5:E9 (the user entered values) exists in your 'Sheet2'!E5:E9 list, the formula will return a 1 else 0 which is the desired result based on your description.
I am trying to add values from different sheets (Sheet 2 to 5) into my main sheet (Sheet 1). In Sheet 1 I want the cells to contain the right formula pointing to the different sheets (if possible).
Typically like this:
='Sheet2'!D5+'Sheet3'!D165
All my sheets have different products, but some sheets contain same products. So I want to search through them all and ADD them in my Main Sheet (Sheet 1).
Sub UpdateMainSheet()
' Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Count As Integer
'Line of code to delete old data in Main Sheet:
Worksheets("Sheet1").Range("A2:H10000").Clear
AktivtArkOverskrift = "List of Articles from Sheet 2 to 5"
'Creates Headline in Main Sheet:
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Sheet1").Cells(eRow, 1) = AktivtArkOverskrift
Worksheets("Sheet1").Cells(eRow, 1).Font.Bold = True
'Script to check and gather data from the other sheets (Sheet 2, 3, 4 and 5):
For K = 2 To 5
'For loop to check each line in sheet "K"
For I = 2 To 1000
'If function to check if the cell I in column F is empty, if so it_jumps to next row and do the same check:
If Worksheets(K).Cells(I, 6) > 0 Then
Count = 0
'For loop to check if I already have a row in the Main Sheet with the article I'm checking:
For L = 2 To 1000
'If function to check if the articles have the same article number:
If Worksheets(K).Cells(I, 1) = Worksheets("Sheet1").Cells(L, 1) Then
'Line of code that are supposed to ADD the values that is currently in the Main Sheet, togheter with the value in Sheet K:
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
End If
Next L
End If
Next I
Next K
End Sub
So what I need to fix in my code is this part (located furthest inside the For Loop):
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
And make it create a formula in the wanted cell, that looks something like this:
='Sheet2'!D5+'Sheet3'!D165
It must be able to add another cell as well, since the Loop are running through several Sheets (Sheet 2 to 5) that may contain the same products.
I.e. I only want one line in my Main Sheet for each product.
I managed to find the solution in the end.
It seemed I had switched the L and I in som of the looping, which resulted in the values not to be added togheter.
The following code (I did not translate to English, but can do this if someone wants/need it) solved my issue, and gave me the values from Sheet 2 to 5 sorted by product in Sheet 1:
Sub OppdaterePlukkelisteSummert()
'Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Teller As Integer
Dim value1 As Integer
Dim value2 As Integer
'Sletter Plukklisten for å oppdatere og sortere på nytt:
Worksheets(1).Range("A2:H10000").Clear
'HENTING AV DATA FRA ARKET "K":
AktivtArk = "Artikler Summert fra Alle Ark"
AktivtArkOverskrift = "Artikler Summert fra Alle Ark"
'Setter inn Overskrift som Forteller kva ark utstyret kommer fra:
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets(1).Cells(eRow, 1) = AktivtArkOverskrift
Worksheets(1).Cells(eRow, 1).Font.Bold = True
'Sjekker hvilke/hvilket rader/utstyr som skal plukkes, og legger det inn i "Ark1":
For K = 2 To 5
For I = 2 To 1000
If Worksheets(K).Cells(I, 6) > 0 Then
Teller = 0
For L = 2 To 1000
If Worksheets(K).Cells(I, 1) = Worksheets(1).Cells(L, 1) Then
value1 = Worksheets(1).Cells(L, 4)
value2 = Worksheets(K).Cells(I, 4)
Worksheets(1).Cells(L, 4) = value1 + value2
Worksheets(1).Cells(L, 6) = value1 + value2
Else
Teller = Teller + 1
End If
Next L
If Teller > 998 Then
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For J = 1 To 11
Worksheets(1).Cells(eRow, J) = Worksheets(K).Cells(I, J)
Next J
Worksheets(1).Cells(eRow, 6).Font.Color = RGB(0, 150, 0)
Worksheets(1).Cells(eRow, 7).Font.Color = RGB(0, 150, 0)
End If
End If
Next I
Next K
Worksheets(1).Range("A2").Select
End Sub
I hope this can be useful for someone else :-)
All help and suggestion in the comments are appreciated!
I was going to illustrate with this simple example:
I = 1 'for example
For K = 2 To 5
Worksheets("Sheet1").Cells(I, 4).Value = Worksheets("Sheet1").Cells(I, 4).Value + _
WorksheetFunction.SumIf(Worksheets(K).Range("A:A"), "Bananas", Worksheets(K).Range("D:D"))
Next K
It's been 6 years since I've worked with Excel and i'm a little bit rusty. Here's my scenario:
I am exporting a list of issues to Excel. I need to be able differentiate the associated Link numbers in a cell (mulitple values) from each other. Example, i have two columns,
Key = the number for a ticket
Linked Issues = The Keys associated
I need a statement that would scan the Key column and find a match in the Linked Issues column. Then once the match is found the matching text will assume the font color of the Key.
Where this get complicated is each cell of the Linked Issues column could look something like this iss-3913, iss-3923, iss-1649. So essentially the scan would be for a match within the string. Any help is appreciated.
I am sorry, I don't have time to finish this right now, but wWould something like this help with maybe a loop for each cell in the first column?
Edit: Finished now, second edit to update to B5 and Z5, edit 3 fixed goof with column reference and updated to use variables to assign what column to look in.
Sub colortext()
start_row = 5
key_col = 2
linked_col = 26
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
o = start_row 'start with row one for second column
Do While Not IsEmpty(Cells(o, linked_col)) 'Do until empty cell
If Not InStr(1, Cells(o, linked_col), Cells(i, key_col)) = 0 Then 'if cell contents found in cell
With Cells(o, linked_col).Characters(Start:=InStr(1, Cells(o, linked_col), Cells(i, key_col)), Length:=Len(Cells(i, key_col))).Font
.Color = Cells(i, key_col).Font.Color 'change color of this part of the cell
End With
End If
o = o + 1 'increment the cell in second column
Loop
i = i + 1 'increment the cell in the first column
Loop
End Sub
or maybe
Something like this?
Excel VBA: change font color for specific char in a cell range
This is an old post but I thought I would provide my work around to the conditional formating issue I was having.
Sub colorkey()
start_row = 5
key_col = 2
flag_col = 4
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
Tval = Cells(i, flag_col).Value
Select Case Tval
Case "Requirement"
'cval = green
cVal = 10
Case "New Feature"
'cval = orange
cVal = 46
Case "Test"
'cval = lt blue
cVal = 28
Case "Epic"
'cval = maroon
cVal = 30
Case "Story"
'cval = dk blue
cVal = 49
Case "Theme"
'cval = grey
cVal = 48
Case "Bug"
'cval = red
cVal = 3
Case "NOT MAPPED"
'cval = Maroon
cVal = 1
End Select
Cells(i, key_col).Font.ColorIndex = cVal
i = i + 1 'increment the cell in the first column
Loop
End Sub
Sub colorlinked()
start_row = 5
key_col = 2
linked_col = 26
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
o = start_row 'start with row one for second column
Do While Not IsEmpty(Cells(o, linked_col)) 'Do until empty cell
If Not InStr(1, Cells(o, linked_col), Cells(i, key_col)) = 0 Then 'if cell contents found in cell
With Cells(o, linked_col).Characters(Start:=InStr(1, Cells(o, linked_col), Cells(i, key_col)), Length:=Len(Cells(i, key_col))).Font
.Color = Cells(i, key_col).Font.Color 'change color of this part of the cell
End With
End If
o = o + 1 'increment the cell in second column
Loop
i = i + 1 'increment the cell in the first column
Loop
MsgBox "Finished Scanning"
End Sub
I want to merge the values in column B if Duplicates exist in Column A
A B
123 A
123 B
123 C
456 D
456 E
789 F
My output should look like this
A B
123 A B C
456 D E
789 F
I have a large amount of data and it is hard to do it manually ,So u guys have any idea to do it in macros in Excel?
Any help will be appreciated..Thanks in Advance
I'd cheat, and use formulas as follows;
1) Sort by column A
2) In col C, add a formula to test if the current one is last (assuming there's a header, put this in C2
=if(A2<>A3,TRUE,FALSE)
Now, this should only be true for the last cell in a series of same ID's
3) in Col D, add a formula for concatenating if the ID's are the same,
=if(A2=A1,D1&" "&B2,B2)
4) Filter on column C to show only the last cell in each series.
Cheers.
In case you want the resultant data in the same cells the original data existed ie not in Cell 10, then you have to store the source data in a two dimensional array. Then from the array we have use the above code to insert the data in the same place the original data existed. Here goes the listing to accomplish the task:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim names(2 To 7, 2)
For i = 2 To 7
names(i, 1) = Cells(i, 1)
names(i, 2) = Cells(i, 2)
Next
On Error Resume Next:
Sheet1.Cells.Clear
cnt = 2
For i = 2 To 7
strg = strg + names(i, 2)
If names(i + 1, 1) <> names(i, 1) Then
Cells(cnt, 1) = names(i, 1)
Cells(cnt, 2) = strg
cnt = cnt + 1
strg = ""
End If
Next
End Sub
Please note that I have declared names array with two dimesnions to store the data. Then the array is searched to get the result.
You can use the following macro:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
cnt = 10
For i = 2 To 7
strg = strg + Cells(i, 2)
If Cells(i + 1, 1) <> Cells(i, 1) Then
Cells(cnt, 1) = Cells(i, 1)
Cells(cnt, 2) = strg
cnt = cnt + 1
strg = ""
End If
Next
End Sub
The requested data will be printed from Cells 10