I'm having a really hard time writing a code for this.
We hence four cells with variable values, a picture should appear depending on the cell with the highest value when a button is clicked.
Example: If cell A1's value is higher than the other cells, picture A should show up when a button is clicked, if cell B1's value is higher, then picture B, which is assigned to that cell, should appear.
We tried our best but couldn't find a solution, any help would be appreciated
Well, this is something trivial, but here is how I would do it:
Public Sub ShowPic()
Me.s1.Visible = b_is_visible(Me.s1.Name)
Me.s2.Visible = b_is_visible(Me.s2.Name)
End sub
Public Function b_is_visible(str_name As String) As Boolean
If str_name = cells(1,1) Then
b_is_visible = True
end if
End Function
In cell A1 you should put the name of the image. Thus, based on it, the image would be either visible or not. The Images should be in a form. The code above is in the form.
There are plenty of solutions. One of them is to have some folder with pictures you wanna display, and name them as rows with max value. E.g. if max value is in row 3, the picture3.jpg file would be displayed.
Sub test123()
Dim Rng As Range
Dim maxRow As Integer, maxVal As Integer
Set Rng = Range("A1:A4")
maxVal = Application.WorksheetFunction.Max(Rng)
picNum = Application.Match(maxVal, Rng, 0)
ActiveSheet.Pictures.Delete
ActiveSheet.Pictures.Insert("K:\user files\user 1\pictures\picture" & picNum & ".jpg").Select
End Sub
EDIT:
If you like to reposition image, you can do it by renaming it and using some commends.
Selection.ShapeRange.Name = "Pic1"
ActiveSheet.Shapes("Pic1").Left = ActiveSheet.Cells(2, 2).Left
ActiveSheet.Shapes("Pic1").Top = ActiveSheet.Cells(2, 2).Top
ActiveSheet.Shapes("Pic1").Height = ActiveSheet.Range("G1:G7").Height
ActiveSheet.Shapes("Pic1").Width = ActiveSheet.Range("B1:G1").Width
Related
I am still new to Visual Basic, and would like to create a macro that essentially fills in empty cells with a value (integer) of zero, while leaving existing cells in the range as they were (if not empty). My code currently is this:
Sub FillEmptyCellsWithZeros()
'this should fill empty cells with a 0 value for the range selected
Dim cell As Object
Dim y As Integer
y = 0
For Each cell In Selection
If y = Empty Then
Selection.Value = 0
ElseIf y <> Empty Then
Selection.Value = ActiveCell.Value
End If
Next cell
End Sub
I know that most likely my loop isn't doing anything in this piece of code, but I cannot seem to get the result and this code was the closest I got.
Any help would be appreciated.
Thank you
Not to take anything away from Scott's answer, but if you're interested in a non-looping answer, you can try something like:
Selection.SpecialCells(xlCellTypeBlanks).Value = 0
this may cause problems if you have a large selection with a lot of discontinuous ranges, but it should be pretty reliable.
Also, if you have a formula that returns a blank (e.g.):
=IF(E16="","")
it will not consider those as blank (meaning they will still "appear" blank after running the code), so your mileage may very.
You are over thinking a little:
Sub FillEmptyCellsWithZeros()
'this should fill empty cells with a 0 value for the range selected
Dim cell As Object
Dim y As Integer
y = 0
For Each cell In Selection
If cell = "" Then
cell = y
End If
Next cell
End Sub
Context:
I have several lists in my sheet (1 column wide, 1-10 rows long). When I right click a cell in these lists, I can do several options, that all work well. I have given a name to the cell at the top of each of these lists (ex. Cell A1 has been given the name cell_1, B10 is names cell_2, etc).
I would like to know if the cell I am right clicking on is the one at the top of the list; is it named "cell_(number)"? If it is not, it checks the cell on top of that one. Does it have a name that starts with "cell_"? If not, check the one on top, etc. Until I can figure out the user clicked on an element of WHICH list.
TL;DR The actual question
I can use ActiveCell.Address, which gives me something like "A1" whether or not I have assigned a name to that cell. ActiveCell.Name gives "Sheet1!A1", so it's not much better. Any idea how to get it to return the name I have assigned instead?
Create a UDF to test the application names, it's less efficient but contains error handling within the function itself:
Sub SO()
'// Example how to call function
Debug.Print GetCellName(Range("A1"))
End Sub
Function GetCellName(myCell As Excel.Range) As Variant
Dim nameCheck As Variant
For Each nameCheck In Application.Names
If Replace(Replace(Replace(nameCheck, "=", ""), "'", ""), "!", "") = _
CStr(myCell.Parent.Name & myCell.Address) Then
GetCellName = CStr(nameCheck.Name)
Exit Function
End If
Next
GetCellName = CVErr(Excel.xlErrName)
End Function
Note you can also use this function in a worksheet cell like so:
=GetCellName(A1)
Perhaps this would work. This function returns the names assigned to a cell (or bigger range for that matter). If there's more than one name, it returns it as an array for array formula...or the user can supply an index to return only the desired name position
Public Function CellIsInRangeNames(sheetname As String, checkRange As Range, Optional itemNumber As Variant) As Variant
Dim oNM As Name
Dim oSht As Worksheet
Dim isect As Range
Dim namesCollection() As Variant
Set oSht = Worksheets(sheetname)
Dim i As Integer
i = -1
For Each oNM In oSht.Names
Set isect = Application.Intersect(Range(oNM.Name), checkRange)
If Not isect Is Nothing Then
i = i + 1
ReDim Preserve namesCollection(0 To i)
namesCollection(i) = CStr(oNM.Name)
End If
Next oNM
If i = -1 Then
'didn't find any
CellIsInRangeNames = xlErrName
ElseIf Not IsMissing(itemNumber) Then
'user wanted this instance only
If (itemNumber - 1 > UBound(namesCollection)) Or (itemNumber - 1 < LBound(namesCollection)) Then
CellIsInRangeNames = xlErrValue
Else
CellIsInRangeNames = namesCollection(itemNumber - 1)
End If
Else 'here's the list as an array
CellIsInRangeNames = namesCollection
End If
End Function
I have this code:
Sub Japan()
Set MyPlage = Range("A1:R1000")
For Each Cell In MyPlage
If Cell.Value = "A" Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
If Cell.Value = "B" Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
If Cell.Value = "C" Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
If Cell.Value = "D" Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
If Cell.Value = "E" Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
Next
End Sub
THis find any cells that have either A, B, C, D, E as the value and then colours the entire row red if so.
Basically, I have hundreds of more values that I want to lookup. I have them stored in another excel file (could just as easily be in a text file). How could I reference them? i.e, if cell value is in this list of text, do this.
Sounds like you want a Set datastructure that contains unique values and you can use an Exist method on it.
For example your desired usage is this.
Set MySet = LoadRedValueSet(???) ' explain later
Set MyPlage = Range("A1:R1000")
For Each Cell In MyPlage
If MySet.Exists(Cell.Value) Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
Next
Well too bad Set is a reserved keyword and VBA does not provide a Set object. However, it does provide a Dictionary object which can be abused like a Set would be. You will need to reference the Scripting Runtime Library to use it first through. The usage would be exactly as stated as above. But first we need to define LoadRedValueSet()
Lets assume that you are able to load whatever file you save these values as in as an Excel worksheet. I will not be explaining how to open various file types in Excel as there are many answers detailing that in more detail than I can. But once you have your range of values to add to the set we can add them to the dictionary.
Private Function LoadRedValueSet(valueRange As Range) As Dictionary
Dim result As New Dictionary
Dim cell As Range
For Each cell In valueRange.Cells
result(cell.value) = Nothing
Next cell
Set LoadRedValueSet = result
End Function
Dictionary are mapping objects that have key->value pairs. The key's are effectively a set, which is what we want. We don't care about the values and you can pass whatever you want to it. I used Nothing. If you use the .Add method the dictionary will throw an error if your list contains duplicate entries.
Assuming you have implemented some function that loads your file as a worksheet and returns that worksheet.
Dim valueSheet As Worksheet
Set valueSheet = LoadSomeFileTypeAsWorksheet("some file path")
Dim valueRange As Range
Set valueRange = valueSheet.??? 'column A or whatever
Dim MyDictAsSet As Dictionary
Set MyDictAsSet = LoadRedValueSet(valueRange)
Set MyPlage = Range("A1:R1000")
For Each Cell In MyPlage
If MyDictAsSet.Exists(Cell.Value) Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
Next
There are quite a few ways you could possibly do this but here's my approach. Application.WorksheetFunction.<function name> can be used to evaluate worksheet functions within VBA. This means we can use it to run a Match function. For the sake of a simple example let's assume your values to match are in Column A of a worksheet called Sheet2 (in the same workbook).
Dim MyPlage As Range, Cell As Range
Dim result as Variant
Set MyPlage = Range("A1:R1000") '<~~ NOTE: Sheets("<SheetName>").Range("A1:R1000") would be better
For Each Cell in MyPlage
result = Application.WorksheetFunction.Match(Cell.Value, Sheets("Sheet2").Range("A:A"), 0)
If Not IsError(result) Then
Rows(Cell.Row).Interior.ColorIndex = 3
End If
Next Cell
We only need to know whether or not the WorksheetFunction.Match function returned an error: If it didn't then Cell.Value was present in Column A of Sheet2 and we color the row red.
Paste your color value + index data to a new sheet called "Colors" in the following order;
Value ColorIndex
A 1
B 2
C 3
D 4
E 5
And update your method with the following code and update the range based your data;
Sub SetColors()
' DataCells: The cells that's going to be checked against the color values
Set DataCells = Range("A1:A15") ' Update this value according to your data cell range
' ColorValueCells: The cells that contain the values to be colored
Set ColorValueCells = Sheets("Colors").Range("A2:A6") ' Update this value according to your color value + index range
' Loop through data cells
For Each DataCell In DataCells
' Loop through color value cells
For Each ColorValueCell In ColorValueCells
' Search for a match
If DataCell.Value = ColorValueCell.Value Then
' If there is a match, find the color index
Set ColorIndexCell = Sheets("Colors").Range("B" & ColorValueCell.Row)
' Set data cell's background color with the color index
DataCell.Interior.ColorIndex = ColorIndexCell.Value
End If
Next
Next
End Sub
I an trying to extract data from sheet "Record" by matching an entered reference number in sheet "Form" with those numbers in column B of "Record." I was able to come up with the VB code below through command button click. However, it will only return a single value from sheet "Record" column i and coding for each will really be time consuming.
Private Sub CommandButton1_Click()
With Application.WorksheetFunction
Sheets("Form").Range("b:b") = _
.Index(Sheets("Record").Range("h:h"), .Match(Sheets("Form").Range("i13"), Sheets("Record").Range("b:b"), 0), 1)
End With
End Sub
I'm wondering if is it possible to copy values from sheet "Record" columns H-Q to sheet "Form" columns B-K if the reference number in cell I13 of sheet "Form" matches any value on column B of sheet "Record?" Because what i encounter most of the time is returning the entire row.
I would really appreciate any help. Thanks
It might be brute force, but I think the best way is to loop through the data like this:
'Find the last row of data
Public Function Get_Last_Row_Find(ByVal rngToCheck As Range) As Long
Dim rngLast As Range
Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, SearchDirection:=xlPrevious)
If rngLast Is Nothing Then
Get_Last_Row_Find = rngToCheck.Row
Else
Get_Last_Row_Find = rngLast.Row
End If
If Get_Last_Row_Find <= 1 Then
Get_Last_Row_Find = 2
End If
End Function
Public Sub CommandButton1_Click
x = Get_Last_Row_Find(Sheets("Record").Range("B:B")
for i = 1 to x
if Sheets("Form").Range("I13").Value = Sheets("Record").Range("B:B").Offset(i-1,0).Value then 'match
Worksheets("Record").Range("H"&i&":Q"&i).Copy _
destination:=Worksheets("Form").Range("B"&i&":K"&i)
next i
Note the two methods of "offsetting": you can use the .Offset method or you can use a variable and concatenate it within the Range("") text.
Code not tested.
I would like to create a macro in excel that lets me increment the counts of a part whenever I press a command button.
Currently, my concept is to use vlookup to get the existing counts for that part using the following. However, it does not increment the actual counts value in the cell, which is what I want. I suspect it's cos vlookup is only used to return a value within the cell, but the cell is not activated in the process for actual increment. Can someone please advise how I can correct it? I'm still new to vba. Thanks!!! :)
E.g. Vlookup finds C1value in Cell A5 of Sheets("Location"). It will automatically increment the value in Cell C5 by 1.
Sub FindAddTools()
Dim C1Qnty As Double
C1value = Sheets("Issue").Range("D11")
Sheets("Location").Activate
C1Qnty = WorksheetFunction.VLookup(C1value, Range("A:D"), 3, False)
C1Qnty = C1Qnty + 1
End Sub
ADD ON: an add-on to my original question. I was wondering if it is possible to do the same for an entire range?
E.g. C1value is now a range of Sheets("Issue").Range("D11:D20"). I want to find all values within this range in Sheets("Location") and increment their corresponding counts in Column C.
Is there a way to do this without repeating the same procedure for all cells of the range?
Thanks! :)
Here's my shot at it. If the value isn't matched nothing happens:
Sub FindAddTools()
Dim RangeToMatch As Excel.Range
Dim cell As Excel.Range
Dim C1Value As Variant
Dim C1Row As Variant
Set RangeToMatch = Sheets("Issue").Range("D2:D11")
For Each cell In RangeToMatch
C1Value = cell.Value
With Sheets("Location")
C1Row = Application.Match(C1Value, .Range("A:A"), 0)
If Not IsError(C1Row) Then
.Range("C" & C1Row).Value = .Range("C" & C1Row).Value + 1
End If
End With
Next cell
End Sub
I edited it so that it cycles through a range of cells to match. That range is set to D2:D11 above.
Based on your comments, I think this should do it.
NB: you don't have to Activate worksheets to perform the functions referencing their cells/ranges.
Sub FindAddTools()
Dim shIssue as WOrksheet: Set shIssue = Sheets("Issue")
Dim shLoc as Worksheet: Set shLoc = Sheets("Location")
Dim allC1Values as Range
Dim C1Value as Variant
Dim C1Qnty As Double
Dim foundRow as Long
Set allC1Values = shIssue.Range("D11:D100") '## Modify as needed.
For each C1Value in allC1Values.Cells
C1Qnty = WorksheetFunction.VLookup(C1value, shLoc.Range("A:D"), 3, False)
C1Qnty = C1Qnty + 1
foundRow = WorksheetFunction.Match(c1Value,shLoc.Range("A:A"),False)
shLoc.Range("C" & foundRow).Value = CqQnty
Next
End Sub
Be careful with this. You're immediately writing to the same cell you just "found" with the VLOOKUP function, so, obviously if you run this macro again, you're going to increment it again. But, this may be the desired functionality, if so, no problem.
NOTE: There is no error trapping for if C1Value is not found in the VLOOKUP or MATCH functions.