I have a workbook with 2 worksheets. On Sheet1 is a list of names in ColC, and on Sheet2 in column C is the same list of names, but spaced out with data in Column D relating to each name almost as a heading. i.e.
Ben 678
700
450
200
Janet 9
23
So I need a vlookup function to Look up the name in ColC Sheet1, and then find the corresponding name in ColC Sheet2, and do an average of the values for that name in ColD until the value in ColC changes (and the next name appears). The number of values in ColD per name changes between 1 and 100 so theres no set range.
(I'm looking for a solution to calculate the average of the last 6 values per name before the next appears - but I can try to modify that later on by myself once I have a structure.)
I am familiar with VBA but no expert, and this is just beyond my ability - I have tried a few things for a few hours and no luck. I have also this code that does a similar thing (I found it on a forum) but only pastes one value and I am not able to modify it enough to suit my needs - it uses VBA to put formulas in specific cells. (it's pretty useless but I thought it was a start)
Sub MCInternet()
'CODE OFF WEB FOR RETURNING VALUE IN COL ... AFTER A LOOKUP OF VALUE IN RANGE - DOESNT ADDRESS RANGE JUST SINGLE CELL
Dim Cll As Range
Dim lngLastRow As Long
lngLastRow = Cells(rows.count, "C:C").End(xlUp).Row
'Sheets("Unpaid List").Range("H2:H" & lngLastRow).ClearContents
For Each Cll In Sheets("Sheet2").Range("C1:C" & Sheets("Sheet2").Range("C1").End(xlDown).Row)
'Cll.Offset(, 6).Formula = "=Vlookup(" & Cll.Address & ", " & Sheets("Sheet1").Name & "!A:C,1,False)"
Cll.Offset(, 6).Formula = "=Vlookup(" & Cll.Address & ", " & Sheets(Sheets.count).Name & "!A:C,1,False)"
Next Cll
End Sub
I think it's better to define in a new module a Public Function like:
Public Function FindP(xx As Range) As Long
Application.Volatile
Dim FoundIndex
Dim SumFound, i As Long
Set FoundIndex = Sheets("Sheet2").Range("C:C").Find(xx.Value)
If (FoundIndex Is Nothing) = True Then
FindP = 0
Exit Function
Else
SumFound = 0
For i = 0 To 100
If (FoundIndex.Offset(i, 0) = "") Or (FoundIndex.Offset(i, 0) = xx.Value) Then
SumFound = SumFound + FoundIndex.Offset(i, 1).Value
Else
Exit For
End If
Next
FindP = SumFound
End If
End Function
and in every cells in the sheet1:
D1 -> =FindP(C1)
and autocomplete.
The function search in the column C of the sheet2 the name, after loop to sum every value if the name in column C it's equal (1st line) or empty (2nd ... n line).
Related
I'm trying to implement a macro that looks for the words "TRUE" and "FALSE" in a huge array of data - and then, when found, changes the color of the cells above it.
Specifically, I would like it to color not the TRUE/FALSE-cell, but the 30 cells directly above it. This is where things get tricky... I hope someone can help.
I've tried adapting the below code, but mostly I'm adding it as inspiration at this point.
Sub ChangeColor()
lRow = Range("C" & Rows.Count).End(xlUp).Row
Set MR = Range("C2:C" & lRow)
For Each cell In MR
Select Case cell.Value
Case "Yes"
cell_colour = 4
Case "y"
cell_colour = 4
Case Else
cell_colour = 3
End Select
cell.Interior.ColorIndex = cell_colour
Next
End Sub
Using a datafield array
Looping through a range is always time consuming; this should speed it up.
Caveat: Formatting single cells can maximize file size, so at least I reformat the whole column C to xlColorIndexNone.
Option Explicit
Public Sub Mark30CellsAbove()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet")
Dim v As Variant
Dim i As Long, j As Long, n As Long, m As Long, r As Long
Dim Rng As Range
Dim t As Double
' stop watch
t = Timer
' get last row in column C
n = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
' get values to one based 2dim array
v = ws.Range("C1:C" & n).Value
' clear existing colors over the WHOLE column to minimize file size
ws.Range("C:C").Interior.ColorIndex = xlColorIndexNone
' loop through C2:Cn and mark 30 rows before found condition
For i = 2 To n
' check condition, find string "true" or "false"
If InStr(".true.false.", "." & LCase(v(i, 1)) & ".") > 0 Then
' set range block - fixed rows count 30 above found cell
If i < 32 Then ' only in case of less than 30 rows
Set rng = ws.Range("C2:C" & (i - 1))
Else
Set rng = ws.Range("C" & (i - 30) & ":C" & (i - 1))
End If
rng.Interior.ColorIndex = 4
End If
Next i
MsgBox "Time needed: " & Format(Timer - t, "0.00") & " seconds."
End Sub
Of course you could also loop within If - EndIf, just to see this slower method:
If InStr(".true.false.", "." & LCase(v(i, 1)) & ".") > 0 Then
' Always avoid to loop through a range
' For j = i - 1 To i - 30 Step -1
' If j < 2 Then Exit For ' optional escape if one line under title row
' ws.Cells(j, 3).Interior.ColorIndex = 4
' Next
End If
The code that I posted should only highlight cells in column B whose value is different from the corresponding cell in column A. I tested it and it worked OK.
If you want to try conditional formatting:
Select column B, or the part of column B that you want to colour conditionally.
In the following, I will assume that B1 is the active cell within the selection.
On the Home tab of the ribbon, click Conditional Formatting > New Rule...
Select "Use a formula to determine which cells to format".
Enter the formula =B1<>A1
If the active cell is not in row 1, adjust the formula accordingly. For example, if the active cell within the selection is B3, use =B3<>A3
Click Format...
Activate the Fill tab.
Select the desired fill colour.
Click OK until all dialogs have closed.
Change some values in column A and/or B to see the result.
Refer - https://social.technet.microsoft.com/Forums/ie/en-US/2fffa4d8-bbba-473b-9346-5fce8f0728a8/using-vba-to-change-a-cell-colour-based-on-the-information-in-a-different-cell-excel-2010?forum=excel
First you need to check whether the row of the cell is higher than 30 and then it you can offset to change the color:
Thus instead of this line: cell.Interior.ColorIndex = cell_colour
write this:
If cell.Row > 30 Then cell.Offset(-30, 0).Interior.ColorIndex = cell_colour
This may be done without VBA. You should set up two conditional formatting with formulas. First:
=COUNTIF(OFFSET(INDIRECT(ADDRESS(ROW(), COLUMN())),1,0,29,1), "TRUE")>0
and the same for false. To highlight the cell you just need to use Highlight Cell Rules (the top option for CF).
I would do this with conditional formatting
Mark all your data and press "Conditional Formatting". Enter 2 rules with Use a formula...
First rule is for TRUE. Assuming that you start with Col A:
=COUNTIF(A2:A31;TRUE)
The second rule is similar, just exchange TRUE by FALSE. Below the formula, press the "Format" button to set the color.
Explanation:
I reverted the logic: Instead of searching for TRUE/FALSE and then format the cells above, I look for every cell if it has at least one entry TRUE resp. FALSE in the next 30 cells. However, I have to admit I don't know how fast Excel can handle such a large amount of data.
first of all I'm a not good at vba, I used many tuts, but It's not what I want ;)
What I'm trying to accomplish:
Select range of hyperlinks in spreadsheet and set hyperlinks to call another spreadsheet cells (always) from A2 to AX (depends on how many rows I selected).
(Sorry for not proper naming, last time I used vba was about 10y ago)
Before run a script: all hyperlinks are set to different spreadsheet to call cell A2, like this: CommLinkItem_57!A2
Important: it can't be used =HYPERLINK(cell;name) function, couse another script is using this spreadsheet and It not work with this function
After run a script: hyperlinks are not incremented from A2 to AX, instead all hyperlinks (event those that I not selected) are calling last iterated element witch is AX
Sub LoopSelection()
Dim cel As Range
Dim selectedRange As Range
Dim aa As String
Dim counter As Integer
counter = 2
Set selectedRange = Application.Selection
For Each cel In selectedRange.Cells
Debug.Print cel.Address & " " & cel.Hyperlinks.Count
If cel.Hyperlinks.Count > 0 Then
aa = cel.Hyperlinks.Item(1).SubAddress
If cel.Hyperlinks.Item(1).SubAddress Like "*!*" Then
cel.Hyperlinks.Item(1).SubAddress = Trim(Split(aa, "!")(0)) & "!A" & counter
End If
counter = counter + 1
Debug.Print cel.Hyperlinks.Item(1).SubAddress
End If
Next cel
End Sub
For example i select 10 cells form I10 to I20 and then I run a script..
My output in console is like this:
$I$10 1
CommLinkItem_57!A2
$I$11 1
CommLinkItem_57!A3
$I$12 1
CommLinkItem_57!A4
$I$13 1
CommLinkItem_57!A5
$I$14 1
CommLinkItem_57!A6
$I$15 1
CommLinkItem_57!A7
$I$16 1
CommLinkItem_57!A8
$I$17 1
CommLinkItem_57!A9
$I$18 1
CommLinkItem_57!A10
$I$19 1
CommLinkItem_57!A11
$I$20 1
CommLinkItem_57!A12
(works fine, finds proper cells (I10:I20), finds one hyperlink, finds spreadsheet named CommLinkItem_57 and set (in console output) proper incremented cell value from A2 to A12
So in excel cell I10 and I20 are calling CommLinkItem_57!A12.
And that's a problem..
Can you point where I made mistake, and how to fix that problem
Your code is OK. The problem is that worksheets maintain a HyperLinks collection of distinct URLs. I suspect your initial URLs are all the same, hence you're always updating the same HyperLink and end up with the one with the highest counter value. If possible, make your initial URLs distinct.
From what I see the counter should be out of the condition. Like this:
For Each cel In selectedRange.Cells
counter = counter + 1
Debug.Print cel.Address & " " & cel.Hyperlinks.Count
If cel.Hyperlinks.Count > 0 Then
aa = cel.Hyperlinks.Item(1).SubAddress
If cel.Hyperlinks.Item(1).SubAddress Like "*!*" Then
cel.Hyperlinks.Item(1).SubAddress = Trim(Split(aa, "!")(0)) & "!A" & counter
End If
Debug.Print cel.Hyperlinks.Item(1).SubAddress
End If
'or put the counter here, it depends on your code...
Next cel
Like #Excelosaurus said, all hyperlinks were reference like, and when I changed one, all were changed too. So I make workaround and create hyperlinks from basics:
I'm counting from A2 to AX so counter is set to 2
Name of table where nested cells are always is in the same column in index 2, so table name sets row 2, and column of a selected range and takes value of cell i.e. tableName
Hyperlinks are created only in active sheet, line: With Worksheets(Application.ActiveSheet.Index)
If we don't want address to url or file, make Address property, i.e. empty quote ""
I think rest is self-explanatory in code:
Sub LoopSelection()
Dim selectedRange As Range
Dim counter As Integer
Dim tableName As String
counter = 2
Set selectedRange = Application.Selection
tableName = Cells(2, selectedRange.Column).Value
For Each cel In selectedRange.Cells
With Worksheets(Application.ActiveSheet.Index)
.Hyperlinks.Add Anchor:=.Range(cel.Address), _
Address:="", _
SubAddress:=tableName & "!A" & counter, _
TextToDisplay:=tableName
End With
counter = counter + 1
Next cel
End Sub
I am trying to figure out how to add some cell values together from different sheets but I don't know what the cells references are as they vary!
Basically the values i need will appear 2 rows below some certain text. So I was looking for a formula that searches multiple sheets, finds the specific text, goes 2 rows below then adds the values together.
Here's something I hope you can adapt to your situation by changing the sheet and row and column range, the text to look for, and the destination of the total.
Sub findfvalues()
Dim rowValue
Dim total
total = 0
For r = 1 To 25 'update this to suit your needs
For c = 1 To 25 'update this to suit your needs
If Cells(r, c).Value = "f" Then 'update "f" to search for what you want
rowValue = r + 2
total = total + Cells(rowValue, c).Value
End If
Next
Next
Cells(30, 1).Value = total 'update this to suit your needs
End Sub
So we just check every cell for the "f" and if we find it, we add the value to a running total. Display the total at the end.
This will look in each worksheet, and if your text is found, add the value that's two rows below to a running total:
Sub find_Values()
Dim ws As Worksheet
Dim findStr As String
Dim foundCell As Range
Dim total As Long
findStr = "my Text"
For Each ws In ActiveWorkbook.Worksheets
Set foundCell = ws.Cells.Find(what:=findStr)
If Not foundCell Is Nothing Then
total = total + foundCell.Offset(2, 0).Value
End If
Next ws
Debug.Print "The value is: " & total
End Sub
What I'd like to do is search for a specific string in a column in one sheet (let's call it Sheet 1), and reference the values in a column adjacent to those matched cells in another sheet (Sheet 2).
To make it more clear, here's a diagram illustrating what I'm trying to do:
What I'd like to do is search the Customer column in Sheet 1 for "Acme", then populate a column in Sheet 2 with each Acme entry's corresponding sample, ignoring any non-Acme entries.
I'm going to guess that this would be more complex than a regular Excel macro and would require a VBA function. Either way, I would be immensely grateful if someone could at least point me in the right direction as to where to begin searching.
Here is a single sheet example, without VBA, that you can adapt to your needs:
In D1 enter:
Acme
In D2 enter the array formula:
=IFERROR(INDEX($A$1:$B$9,SMALL(IF($A$1:$A$9=$D$1,ROW($A$1:$A$9)),ROW(1:1)),2),"")
and copy down.
Array formulas must be entered with Ctrl + Shift + Enter rather than just the Enter key.
This will find the first row of sheet1 with customer "Acme". It will find the first row of sheet2 with the customer name "Acme" and add the contents of sheet1 "Acme" row column C to whatever is in sheet2 Acme row column "C". It assumes these numbers are values, not strings. You can change that by deleting the addition. You can also change columns or anything else to suit your needs.
Sub updateSheet2()
Dim customerNameColumnSheet1 As String, customerNameColumnSheet2 As String
Dim lastRowSheet1 As Long
Dim lastRowSheet2 As Long
Dim customerName As String
Dim Sheet1Row As Long
Dim Sheet2Row As Long
customerNameColumnSheet1 = "A"
customerNameColumnSheet2 = "A"
customerName = "Acme" ' or customerName = Sheet1.Range("A12").value, etc
lastRowSheet1 = Sheet1.Cells(Rows.Count, customerNameColumnSheet1).End(xlUp).row
lastRowSheet2 = Sheet2.Cells(Rows.Count, customerNameColumnSheet2).End(xlUp).row
With Sheet1.Range(customerNameColumnSheet1 & "1:" & customerNameColumnSheet1 & lastRowSheet1)
Set c = .Find(customerName, LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
Sheet1Row = c.row
With Sheet2.Range(customerNameColumnSheet2 & "1:" & customerNameColumnSheet2 & lastRowSheet2)
Set D = .Find(customerName, LookIn:=xlValues, lookat:=xlPart)
If Not D Is Nothing Then
Sheet2Row = D.row
Sheet2.Range("C" & Sheet2Row).Value = Sheet1.Range("C" & Sheet1Row).Value' + Sheet2.Range("C" & Sheet2Row).Value ' assuming values, not string
End If
End With
End If
End With
End Sub
I am trying randomly generate a whole number between 1 and 100, whether that be in a cell or in the vba code directly. Then I want to use that value as the lookup value for a VLookup that will pull another randomly generated whole number between 1 and 10 from a different sheet. Then I want to use that second number between 1 and 10 as an indicator to fill in that many cells in a column with the first number between 1 and 100.
So for example if I were doing it manually: I would have in cell "C27" on Sheet1 =MROUND(RANDBETWEEN(1,100),1). Let's say it returns 40. Then I would look on Sheet2 for number 40 in column A, look over to Column D where there is another =MROUND(RANDBETWEEN(1,10),1). Let's say that one returns 5 (so I need to fill in 5 cells of a column). Then I would head back to Sheet1 and enter 40 into cells K31 through K35 (the original random whole number).
I'm aware that RAND and RANDBETWEEN update anytime the worksheet recalculates. I use triggered IF statements to keep them from updating unless I change a value in a trigger cell. If generating a random number with VBA makes that even easier, I'm all for it.
I don't think it will be helpful for me to post the many iterations I've attempted as I've tried to apply solutions to each individual task of this macro. None of them have seemingly even gotten me close. But here's what I'm using right now that's also not even close. This code was for me to try and get it to work period. So the numbers are static and not random. But I need them random. And yes, this is for me to generate random monsters for my D&D game mastering :)
Thanks to anyone who might be able to get me on the right track!
Sub MonsterRoll()
'
' MonsterRoll
Dim ws As Worksheet
Dim roll As Integer
Dim No1 As Integer
Dim No2 As Integer
Set ws = Sheets("Combat Helper")
roll = 5
No1 = 31
No2 = 31 + 5
On Error Resume Next
For i = No1 To No2
area.Cells(i, 11).Value = 5
Next
End Sub
This table houses the vlookups into sheet "Encounters"
This table contains the source data, with column D being a RANDBETWEEN
I'm still not sure about a few cell references, but think I have a general idea. The code below can be a starting point to do most of what you want -- with a few warnings...
Since you are monitoring for changes in Sheet1 cells K31:K50, and then making changes to that same range, that will trigger the change event again. So, to avoid crazy results, I added a flag so that it will ignore changes untill you tell it to stop ignoring. That will be when you have finished all processing for your original change.
Personally, I would prefer to generate my own random numbers via code for the simple reason that ANY change to any cell will trigger all of your 'random' numbers to regenerate.
Go to Function 'Set_All_Cell_Values' and add whatever code you need to fill other cells.
Option Explicit
Dim blnIgnoreChanges As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer
Dim iYourNbr As Integer
Dim iMyNbr As Integer
Dim iRow As Integer
Dim iHowMany As Integer
Dim Why As String
' The following code can be dangerous if your code is not working properly!!!!
' Since you want to 'monitor' changes to K31:K50, and then change those same cells via code,
' which will in turn trigger this 'Worksheet_Change' subroutine to fire again,
' you need to be able to ignore changes on demand.
' If this flag gets set and your code didn't complete (AND turn the flag off), then
' any monitoring of future changes will be ignored!!
' If the flag fails to get reset, then just execute the following code in the immediate window:
' blnIgnoreChanges = false
If blnIgnoreChanges = True Then
Exit Sub
End If
Set ws1 = ThisWorkbook.Worksheets("Combat Helper")
Set ws2 = ThisWorkbook.Worksheets("Encounters")
' Sample data in Sheet2
' A B C D E F G H I J
'40 Bird, Falcon 1 1 1 -10 5 2 1d4 t
'41 Men: Wild Man 2 3 2 -9 2 3 1d5 u
'42 Beast 3 5 3 -8 3 4 1d6 v
'43 Elephant 4 7 4 -7 4 5 1d7 w
' Monitor only cells K31:K50
If Target.Row >= 31 And Target.Row <= 50 And Target.Column = 11 Then
' Value must be between 1 and 100
If Target.Value < 1 Or Target.Value > 100 Then
MsgBox "Must enter between 1 and 100"
Exit Sub
Else
' If you want to Lookup match in Col A of Sheet2, and then get value from col D.
iYourNbr = Application.VLookup(Target.Value, ws2.Range("A3:N102"), 4, False)
' I prefer to Generate my own random number between 1 and 10
iMyNbr = Int((10 - 1 + 1) * Rnd + 1)
iRow = Find_Matching_Value(Target.Value)
Debug.Print "Matching Row in Sheet2 is: " & iRow
' DANGER!! If you execute the following line of code, then you MUST set to FALSE
' when you have finished one change!!!
blnIgnoreChanges = True
iHowMany = Sheet2.Cells(iRow, 4).Value
Sheet1.Cells(Target.Row, 13) = iHowMany
Set_All_Cell_Values Target.Row, iRow, iHowMany
End If
' We can ignore all other cell changes
Else
'Debug.Print "Change made to: " & "R" & Target.Row & ":C" & Target.Column & " but not my row or column! Value is:" & Target.Value
End If
End Sub
Function Set_All_Cell_Values(iS1Row As Integer, iS2Row As Integer, iHowMany As Integer)
Dim i As Integer
Debug.Print "Add code to set cells for Sheet1 R:" & iS1Row & " Sheet2 R:" & iS2Row
For i = iS1Row + 1 To iS1Row + iHowMany - 1
Sheet1.Cells(i, 11) = Sheet1.Cells(iS1Row, 11)
'#################################################
' ADD CODE TO FILL OTHER CELLS as needed!!!
'#################################################
Next i
blnIgnoreChanges = False
End Function
Function Find_Matching_Value(iFind As Integer) As Integer
Dim Rng As Range
If Trim(iFind) <> "" Then
With Sheets("Encounters").Range("A:A")
Set Rng = .Find(What:=iFind, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Find_Matching_Value = Rng.Row
Else
MsgBox "Did not find match for value: " & iFind
End If
End With
Else
MsgBox "You passed an empty value to 'Find_Matching_Value'"
End If
End Function