VBA Assistance needed - lookup, match and copy command

[Hurley]

VBA Command Example.xlsb

Hello

I’m in some need regarding a command with the intention being to lookup, find and in turn match figures in three columns according to a set scale and then copy the corresponding cells to a different tab.

I have tried and so far, ultimately failed to get my head around this, so any assistance given is appreciated.

A full rundown of what is required is attached and below.

Within Tab 1, what is required is detail from columns K, O and P to be automatically transposed into their corresponding columns on Tab 2 in line with Column C on Tab 1 and 2.

The manner of this command is dependent on an existing scale (Very High, High, Moderate, Low, Very Low) and must be processed in order of;

1. Very High
2. High
3. Moderate
4. Low
5. Very Low

The command needs to look along column J in order of the scale above and copy the corresponding values from K, O and P into the cells on Tab 2.

There could be an instance whereby a figure has appeared twice (1 and 2) in the set priority scale such as;

Column J Column K
1 High A13
2 High A13
3 High A21

In this instance, the first instance of A13 (1) would be copied across and the second copied cell would be A21 (3) as it is the next best match in line with the priority scale that is not a duplicate

Column J Column K
1 High A13
2 High A13
3 High A21

I.e. if Column J matches, copy detail from Column K into Tab 2 and move onto next row in line with set scale. If column J doesn’t match then move onto next row in line with set scale

The command would then work down through the set scale (Very High, High, Moderate, Low, Very Low) until all entries are complete and copied over into the corresponding cells on Tab 2.

An example output is on the attached sheet and coloured in yellow on Tab 2. If this needs a trigger button to run the command, I am comfortable with that.

Many thanks for reading, any assistance will be very much appreciated.

[georgiboy]

Hi Hurley,

Are you looking to empty the table on Tab2 and create new data in the order specified above?
or
Do you want to lookup the values from tab 1 and find on tab 2 then add the values to the existing table?

[Hurley]

Hi Georgiboy, first of all thanks for reading and replying.

In regards to your question, it would be the second question; to lookup the values from tab 1 and add the values to table on tab 2 in line with the parameters labelled above.

Row 16 on Tab 2 (highlighted yellow) is the best example of what is required after the process would have been completed.

[georgiboy]

Ok i think i may have missuderstood, the attachment below is where i got to with it, it may not be the best approach. Not to worry though as i am sure one of the others will be along with some more options. I generally don't work with tables (not sure why), might be because i am old

[arnelgp]

is this close to what you need?
i am saving it to Tab3.

[Hurley]

Hi georgiboy and arnelgp

Thank you so much for your help! Both do the main crux of what I'm after (which is amazing thank you!).

One element that may need to be added is if a person has already been accounted for he should be discounted from the calculations.

For example, if person A13 is listed twice the first instance is added to the table/taken into account and the second should be discounted and not duplicated on the output table regardless of Group No. with the next best match by order of priority should be taken into account. If it then needs to be the first person in the next category this should then be actioned.

Hope that makes sense and once again, thank you for your time and help.

[arnelgp]

here is the modified version, will not include duplicate Group + Priority.

[Hurley]

Hello

Thanks for this, I'm getting the following message however?

Run Time Error '429' ActiveX component cant create object

In the debug also the following is highlighted..

Set vh = CreateObject("scripting.dictionary")


Are you able to assist? - Thanks again for your help also

[arnelgp]

it should work, unless there is problem with Microsoft Scripting, not properly installed..
anyway, i changed it again to Collection (instead of Dictionary).

[Hurley]

Hi Arnel (and georgiboy), thanks for that - appreciated. I think you have solved the problem! Really appreciate it

[snb]

Or, rather simply:

Sub M_snb()
   sn = ListObjects(1).Range
   
   For j = 2 To UBound(sn)
     If InStr(c00, sn(j, 10) & sn(j, 11)) = 0 Then
        c00 = c00 & "_" & sn(j, 10) & sn(j, 11)
        sn(j, 10) = InStr("VHML", Left(sn(j, 10), 1)) - 4 * (sn(j, 10) = "Very Low") & sn(j, 10)
     Else
        sn(j, 11) = ""
     End If
   Next
   
   with Cells(30, 1).Resize(UBound(sn), UBound(sn, 2))
     .value= sn
     .Columns(11).SpecialCells(4).EntireRow.Delete
     .Sort Cells(30, 10), , Cells(30, 11), , , , , 1
   end with
End Sub

[Hurley]

Thanks snb.

Arnelgb and Georgiboy - I've just sent you a message if you're able to assist. Just wary that I've marked this thread as solved.

[Aussiebear]

@Hurley Please keep the thread going rather than using PM to the participants. Others trying to follow the thread will be blocked from the logic.

[arnelgp]

@Hurley Please keep the thread going rather than using PM the participants. Others trying to follow the thread will be blocked from the logic.

Well, obviously the OP does not want anyone else get involved?
i don't even have a chance to look and see what the message is?
instead of deleting the Original message, just Add a note that you
moved it to regular thread so the recipient can have a chance to read it.

[Aussiebear]

@arnelgp, I would like to refer you to the FAQ's for a better understanding of how the forums operates;

Can I contact someone privately (via PM) if I need help?

Please don't PM other members directly with a question when there is a whole forum dedicated to the solving of such problems. We kindly ask that you post your question to the relevant subforum of this site as:

• This is a free subscription forum and opens up your problem to many different viewpoints and levels of experience from which you can benefit;
• Questions made public benefit the site and declare an unselfish wish to help others who may have a similar problem in the future by allowing them to search for a solution rather than post a question which has been answered before;
• A direct enquiry, when unsolicited, is not regarded as proper netiquette as the person you are contacting may not have the time - or may not be willing - to help you;
• Soliciting an individual response is akin to consultancy for which the person contacted may charge for their private services.

Thanks for reading and good luck with your problem.


If you believe this is wrong in any context, please forward your issue to the Admin.

[arnelgp]

to the OP, overwrite cpyByPriority sub with this one:

Public Sub cpyByPriority()
    Dim colAll As New Collection
    Dim colOut As New Collection
    
    Dim sht As Worksheet
    
    Dim src_range As Range
    Dim trg_range As Range
    Dim start_row As Long
    Dim end_row As Long, i As Long
    
    Dim stat As String, ky As String
    Dim value As Variant, v As Variant, itm As Variant
    
    Set sht = Sheets("tab1")
    
    Set src_range = sht.ListObjects(1).DataBodyRange
    start_row = src_range.Row
    end_row = start_row + src_range.Rows.Count - 1


    With sht
        On Error Resume Next
        For i = start_row To end_row
            stat = .Range("j" & i).value & ""
            ky = .Range("C" & i).value
            value = .Range("C" & i).value & "|" & .Range("J" & i).value & "|" & .Range("K" & i) & "|" & .Range("O" & i) & "|" & .Range("P" & i)
            itm = colAll.Item(ky)
            If Err Then
                colAll.Add Key:=ky, Item:=1
                colOut.Add Key:=(colOut.Count + 1) & "", Item:=value
            End If
            Err.Clear
        Next
    End With
    
    '!!!!!!!!!!!!!!!!
    ' Change the sheet to your target sheet
    '
    Set sht = Sheets("Tab3")
    
    
    Set src_range = sht.ListObjects(1).DataBodyRange
    start_row = 2
    If Not src_range Is Nothing Then
        start_row = src_range.Row
    End If
    With sht
        For i = 1 To colOut.Count
            value = colOut(i)
            v = Split(value, "|")
            .Range("C" & start_row).NumberFormat = "@"
            .Range("C" & start_row) = v(0) & ""
            .Range("J" & start_row) = v(1)
            .Range("K" & start_row) = v(2)
            .Range("O" & start_row) = v(3)
            .Range("P" & start_row) = v(4)
            start_row = start_row + 1
        Next
    End With
        
    Set colAll = Nothing
    Set colOut = Nothing
    
    MsgBox "Done! Please goto Tab3 sheet."
        
End Sub

Note that Priority has no bearing now, since you need the "first occurrence" only.
example:

entry for a123
first entry as "low"
next enty as "very high"

low priority will be considered since it is the first entry.

[Hurley]

it should work, unless there is problem with Microsoft Scripting, not properly installed..
anyway, i changed it again to Collection (instead of Dictionary).

My apologies Aussiebear, duly noted.

Hi Arnel, I seem to have found a way around the duplication issue by changing the code to ky = .Range("K" & i).value

The last remaining piece is there a way that the cells are not sorted by priority once copied over via the command - this is resulting in formulas being erroneous in other areas of the document.

Example being currently the items are being copied over and sorted into order of priority on Tab 3 however can they be copied over in the order displayed on Tab 1?

[arnelgp]

i remove the filtering on the table (to show all hidden row first).
then remove the sorting before processing.