VBA Check for multiple cell values and copy the cell in column A

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows
Hello!

So I have this code that checks for the values in column "L" in this case it's 25. But I want to change this code so that it actually checks for the value in column "J" and "K". So for example right now if we get the value 25, it copy's the cell in column A and paste's it in different sheet in cell "G1".

What I want to accomplish is to check for the values in the column "J" and "K" and if for example both of the values are "5" then again copy the cell value in Column "A" and paste it the other sheet in "G1" because when you multiple 5*5 it's 25, but if the values are for example "J" is 5 and "K" is 4 then it's 20, so it should paste the cell value from column "A" into the other sheet in cell "F1". But again if the value in "J" is 4 and in "K" it's 5 then also 20, but now it should actually paste the value now not in "F1"but "G2" a It's like a multiplier and according to the values of these both numbers I have to put them in the correct place in the map that you can see below. I guess it will be a lot of if else statements or something, because it has to check all the possible values which are in column "J" 1-5 and in "K" also 1-5.

THIS IS THE CODE THAT I HAVE RIGHT NOW.

VBA Code:
Public Sub FindingValues()
    Dim val As Integer, result As String, firstAddress As String
    Dim a As Range

    val = 25
    Set a = Sheets("riskuregistrs").Range("L:L").Find(val, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)

    If Not a Is Nothing Then
        firstAddress = a.Address

        Do
            If Len(result) > 0 Then
                result = result & "," & a.Offset(0, -11).Text
            Else
                result = a.Offset(0, -11).Text
            End If

            Set a = Cells.FindNext(a)
        Loop While Not a Is Nothing And a.Address <> firstAddress
    End If

    Sheets("Riskukarte").Range("G1").Value = result
End Sub

These are the excel sheet's where I have to take the value from and the third image is the map where the values from column "A" from the first sheet should be pasted. As you can see in cell "G1" it pasted all the cell values that had number 25 in column "L".

enter image description here

enter image description here

enter image description here

I will appreciate any help I could get. Thank you so much in advance! If there is any other questions regarding this, please - ask.
 

Some videos you may like

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows
Anthony! You are amazing human being! I couldn't ask for more. It's amazing, works just perfectly. You really helped me out here, and I really appreciate it! You spent a lot of your own time just to help me out, and I appreciate it! Thank you again for your time and effort!
 

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows
Anthony I just realized, is it actually possible to display the number values and on top of the numbers it shows these small shaped boxes? As I can see it doesn't show the numbers from 1-25

When I change the values to the numbers the shapes stay, but if I run the code again it displays the column "A" values.
 
Last edited:

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
1,916
So we need an addictional layer, ie this additional code:
VBA Code:
Sub AddMk(Dummy)
'Add watermarks
Dim hPos As Integer, vPos As Integer, Diam As Integer
Dim Center As Boolean
'
Application.ScreenUpdating = True
DoEvents: DoEvents
Center = True              '<<< Center True or False (Centered or TopLeft)
For J = 1 To 5
    For K = 1 To 5
        Diam = Range("C1").Cells(6 - K, J).Height / 2
        If Center Then
            hPos = Range("C1").Cells(6 - K, J).Left + Range("C1").Cells(6 - K, J).Width / 2 * 1 + Diam / 2 * 0
            vPos = Range("C1").Cells(6 - K, J).Top + Range("C1").Cells(6 - K, J).Height / 2 * 1 + Diam / 2 * 0
        Else
            hPos = Range("C1").Cells(6 - K, J).Left + Range("C1").Cells(6 - K, J).Width / 2 * 0 + Diam / 2
            vPos = Range("C1").Cells(6 - K, J).Top + Range("C1").Cells(6 - K, J).Height / 2 * 0 + Diam / 2
        End If
        Call Marker(hPos, vPos, Diam, K * J)
    Next K
Next J
End Sub


Sub Marker(xxPos As Integer, yyPos As Integer, cSize As Integer, cTxt As String)
'Create and format WMs
    ActiveSheet.Shapes.AddShape(msoShapeOval, xxPos - cSize / 2, yyPos - cSize / 2, cSize, cSize).Select
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = cTxt
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters. _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignLeft
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = cSize / 2
        .Name = "+mn-lt"
        .Bold = True
    End With
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0.6399999857
        .Solid
    End With
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0.6
        .Solid
    End With
    With Selection.ShapeRange.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorNone
    End With
    Selection.ShapeRange.TextFrame2.MarginTop = 2
    Selection.ShapeRange.TextFrame2.MarginBottom = 2
    Selection.ShapeRange.TextFrame2.WordWrap = msoFalse
    Selection.ShapeRange.TextFrame2.TextRange.Font.Line.Visible = msoFalse
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignCenter
    Selection.ShapeRange.ZOrder msoBringToFront
End Sub
The instruction marked <<< (initial lines) let you define if the position of these markers is at the Center of the cell (Center = True) or at the Top-Left (Center = False)
Note that this code is mostly obtained by the command "record new macro", so there is a little bit of redundancy.

Of course we also need to "call" this new procedure from the main macro, so we need to modify the last portion of Sub RiskMap22 as follows:
VBA Code:
'Modified area >>>
'Select Output sheet and populate:
oSh.Select
oSh.Range("C1").Resize(5, 5).Value = OArr   'Cell values
Application.ScreenUpdating = False
Call TBPos(OArr)                            'Set Shapes
Call AddMk(0)                               'Set "watermark"
DoEvents
MsgBox ("Done...")
Application.ScreenUpdating = True
'Autozoom the output table:
Range("C1").Resize(5, 5).Select
ActiveWindow.Zoom = True
Range("C1").Select
End Sub
Note also the added Application.ScreenUpdating = False because my screen was flickering too much during the insertion of the shapes

Bye
 

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Hi Anthony!

I like the way u did it, but the question is: "Is it not possible to hide the values"? I mean the values that you can see behind the numbers and the shapeboxes. So that it looks clean.
So instead of the way it looks now:

testtest.png


To this:

testttt2.png
 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
1,916
Anthony in msg #9 said:
Note that, at the moment, the cells are still compiled as they were with the previous macro. This is mainly for cheching that the shapes reflect the calculated Risk Id. If cells are formatted for "wrap text", "horizontal central alignement" and "vertical central alignment" probably the cells values are hidden by the shapes; in this case doublecliccking the cell will make the content fully visible
Clearly your cell format doesn't include "center alignment", so the notes are well visible.

To avoid those notes in the cells you have a couple of options:
a) remove the line oSh.Range("C1").Resize(5, 5).Value = OArr 'Cell values in Sub RiskMap22
b) OR, set the table for "center alignment", both vertical and horizontal, plus font size=1. In this way the cells will be populated but their content will be quite invisible in the cell, but you can examine it into the formula bar.

Make your choice
 

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Hey Anthony! Will try! Before that is it possible to make the numbers look like this: It is with no filter and with no outline, also I can see that the size for all of the numbers are not quite the same as the middle row numbers compared to others are quite huge, how to fix it?

TESSSSTT.png
 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
1,916
The size of the marks is calculated with respect to the height of the current line; either you make the table using the same height (and width) for all the cells (and this is my recommended solution; see message #9) or you set the size manually, or you use always C1 height: so, in Sub AddMk(Dummy) replace Diam = Range("C1").Cells(6 - K, J).Height / 2 by
VBA Code:
Diam = Range("C1").Height / 2

To remove the color from the circle, the easiest way is that you manipulate the Transparency of the assigned fill color.
That is, in Sub Marker(xxPos As Integer, yyPos As Integer, cSize As Integer, cTxt As String) :
VBA Code:
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 1   '0.6399999857       '<<<<<  1=100% transparent
        .Solid
    End With

If necessary, you can also manipulate the transparency of the number, see the With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill block

Bye
 

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows
Hi Anthony! Everything now looks nice, last thing - How to remove the circles around the numbers? Manually you can remove it by pressing "No Outline"
 

Goldyyyy

New Member
Joined
Nov 9, 2020
Messages
14
Office Version
  1. 2019
Platform
  1. Windows
also, when counting the shapes I counted 91 of them while in the "Risku registrs" there is 93, any clue why is that?
 

Watch MrExcel Video

Forum statistics

Threads
1,113,892
Messages
5,544,893
Members
410,643
Latest member
sng
Top