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.
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
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!
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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"
 
Upvote 0
also, when counting the shapes I counted 91 of them while in the "Risku registrs" there is 93, any clue why is that?
 
Upvote 0

Forum statistics

Threads
1,213,530
Messages
6,114,163
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top