Match all values within a filtered range based on multiple criteria

H

HarveySpecter

New Member
Joined
Jan 4, 2019
Messages
4
Hello All,

I've started playing with VBA some days ago, thus I'm new with Excel coding.

Below is a simplified version of the sheet I want to extrapolate the data from (sheet name "Data"):

[TABLE="width: 332"]
<tbody>[TR]
[TD="class: xl66, width: 83"]Customer[/TD]
[TD="class: xl66, width: 83"]Platform[/TD]
[TD="class: xl66, width: 83"]Program[/TD]
[TD="class: xl66, width: 83"]Motor Type[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]aa[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]aa[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr3[/TD]
[TD="class: xl65"]aa[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr4[/TD]
[TD="class: xl65"]cc[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr5[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr3[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr4[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr5[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]aa[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]bb[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr3[/TD]
[TD="class: xl65"]bb[/TD]
[/TR]
[TR]
[TD="class: xl65"]A[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr4[/TD]
[TD="class: xl65"]bb[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]cc[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr3[/TD]
[TD="class: xl65"]cc[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr4[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]bb[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]cc[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr3[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]B[/TD]
[TD="class: xl65"]4[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]aa[/TD]
[/TR]
[TR]
[TD="class: xl65"]C[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]C[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]C[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]cc[/TD]
[/TR]
[TR]
[TD="class: xl65"]C[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]bb[/TD]
[/TR]
[TR]
[TD="class: xl65"]D[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]dd[/TD]
[/TR]
[TR]
[TD="class: xl65"]D[/TD]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]dd[/TD]
[/TR]
[TR]
[TD="class: xl65"]D[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]ee[/TD]
[/TR]
[TR]
[TD="class: xl65"]D[/TD]
[TD="class: xl65"]4[/TD]
[TD="class: xl65"]pr1[/TD]
[TD="class: xl65"]bb[/TD]
[/TR]
[TR]
[TD="class: xl65"]D[/TD]
[TD="class: xl65"]4[/TD]
[TD="class: xl65"]pr2[/TD]
[TD="class: xl65"]cc[/TD]
[/TR]
</tbody>[/TABLE]


What I'd like to do is to filter the columns "Customer" and "Platform" based on the values of the columns A and B of the sheet "First 50 Programs" (I though of creating a loop with the autofilter function) and run an if-statement that checks all the cells among the visible cells of the column "Motor Type" of the sheet "Data" that match multiple criteria as shown below.


  1. if within the visible cells of filtered range (column "Motor Type"), there is at least one cell with the text "aa" or "bb" or "cc" or "dd" AND no cells with "ee", then return in column "Motor Category" the text "Conventional"
  2. if within the visible cells of filtered range (column "Motor Type"), there is at least one cell with the text "aa" or "bb" or "cc" or "dd" AND also at least one cell with text "ee", then return in column "Motor Category" the text "Multienergy"
  3. if within the visible cells of filtered range (column "Motor Type"), there are no cells with the text "aa" or "bb" or "cc" or "dd" AND there is at least one cell with text "ee", then return on cell "Motor Category" the text "Electric"

At the end of the macro, the result should appear on the sheet "First 50 Programs" as follows:
[TABLE="width: 337"]
<tbody>[TR]
[TD]Customer[/TD]
[TD]Platform[/TD]
[TD]Motor Category[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]1[/TD]
[TD]Multienergy[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]2[/TD]
[TD]Electric[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]3[/TD]
[TD]Conventional[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]1[/TD]
[TD]Multienergy[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]2[/TD]
[TD]Conventional[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]3[/TD]
[TD]Electric[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]4[/TD]
[TD]Conventional[/TD]
[/TR]
</tbody>[/TABLE]



This is the code I have tried to apply, but it doesn't work
icon9.png



Code: 
Sub Types_Of_Platforms()

Dim i As Long
Dim lRow As Long
Dim VisCell, c As Range


lRow = Worksheets("First 50 Programs").Cells(Rows.Count, 2).End(xlUp).Row


For i = 5 To lRow
    Sheets("Data").Select
    With ActiveSheet.Range("$A$1:$D$34")
        .AutoFilter Field:=1, Criteria1:=Sheets("First 50 Programs").Range("A" & i).Value
        .AutoFilter Field:=2, Criteria1:=Sheets("First 50 Programs").Range("B" & i).Value
    End With
    Set VisCell = Worksheets("Data").Range("D1:D34").SpecialCells(xlCellTypeVisible)
    For Each c In VisCell.Cells
        If c.Value2 = "aa" Or c.Value2 = "bb" Or c.Value2 = "cc" Or c.Value2 = "dd" And c.Value2 <> "ee" Then
            Sheets("First 50 Programs").Range("C" & i).Value = "Conventional"
        ElseIf c.Value2 <> "aa" And c.Value2 <> "bb" And c.Value2 <> "cc" And c.Value2 <> "dd" And c.Value2 = "ee" Then
            Sheets("First 50 Programs").Range("C" & i).Value = "Only BEV"
        ElseIf c.Value2 = "aa" Or c.Value2 = "bb" Or c.Value2 = "cc" Or c.Value2 = "dd" And c.Value2 = "ee" Then
            Sheets("First 50 Programs").Range("C" & i).Value = "Multi-Energy"
        Else: Sheets("First 50 Programs").Range("C" & i).Value = "Error"
        End If
    Next c


Next i


End Sub

Thanks a lot.
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
Try this from sheets "Data" to results, starting Sheet2 "A1".
Code: 
[COLOR="Navy"]Sub[/COLOR] MG04Jan48
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] A1 [COLOR="Navy"]As[/COLOR] Boolean, B1 [COLOR="Navy"]As[/COLOR] Boolean, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Msg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Data")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
  [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
   .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Txt = Dn.Value & "," & Dn.Offset(, 1).Value

[COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        A1 = False: B1 = False
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 3)
            [COLOR="Navy"]Case[/COLOR] "aa", "bb", "cc": A1 = True
            [COLOR="Navy"]Case[/COLOR] "ee": B1 = True
        [COLOR="Navy"]End[/COLOR] Select
        .Add Txt, Array(A1, B1)
    [COLOR="Navy"]Else[/COLOR]
      Q = .Item(Txt)
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 3)
             [COLOR="Navy"]Case[/COLOR] "aa", "bb", "cc": A1 = True
              [COLOR="Navy"]Case[/COLOR] "ee": B1 = True
         [COLOR="Navy"]End[/COLOR] Select
          Q(0) = A1
          Q(1) = B1
     .Item(Txt) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To .Count + 1, 1 To 3)
c = 1
Ray(1, 1) = "Customer": Ray(1, 2) = "Platform": Ray(1, 3) = "Motor Category"

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] .Item(K)(0) & "," & .Item(K)(1)
        [COLOR="Navy"]Case[/COLOR] True & "," & True: Msg = "Multienergy"
        [COLOR="Navy"]Case[/COLOR] True & "," & False: Msg = "Conventional"
        [COLOR="Navy"]Case[/COLOR] False & "," & True: Msg = "Electric"
        [COLOR="Navy"]Case[/COLOR] Else: Msg = ""
    [COLOR="Navy"]End[/COLOR] Select
    [COLOR="Navy"]If[/COLOR] Not Msg = "" [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Ray(c, 1) = Split(K, ",")(0)
        Ray(c, 2) = Split(K, ",")(1)
        Ray(c, 3) = Msg
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Hi Mike,

Thanks a lot for the quick response.
Wow! I have still so much to learn about VBA. Your code looks coming from another world to me :rolleyes:

I've been trying to adapt your code to my original file 'cos the columns' position are different compared to the simplified example I posted.
Unfortunately, I've been having some troubles since I don't fully understand what you did :oops:

These are the real columns' positions:


Sheet "Data"

Customer: J6:J50192
Platform: P6:P50192
Programs: Q6:Q50192
Motor Type: BK6:BK50192


Sheet 2 (alias "First 50 Programs")

Customer: A4:A54
Platform: B4:B54
Motor Category: E4:E54

How should I change your code so that it will work in the original file?

Thanks again.

Regards
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Jan35
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] A1 [COLOR="Navy"]As[/COLOR] Boolean, B1 [COLOR="Navy"]As[/COLOR] Boolean, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Msg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Data")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("J7", Range("J" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
  [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
   .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Txt = Dn.Value & "," & Dn.Offset(, 6).Value

[COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        A1 = False: B1 = False
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 53)
            [COLOR="Navy"]Case[/COLOR] "aa", "bb", "cc": A1 = True
            [COLOR="Navy"]Case[/COLOR] "ee": B1 = True
        [COLOR="Navy"]End[/COLOR] Select
        .Add Txt, Array(A1, B1)
    [COLOR="Navy"]Else[/COLOR]
      Q = .Item(Txt)
         [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 53)
             [COLOR="Navy"]Case[/COLOR] "aa", "bb", "cc": A1 = True
             [COLOR="Navy"]Case[/COLOR] "ee": B1 = True
         [COLOR="Navy"]End[/COLOR] Select
          Q(0) = A1
          Q(1) = B1
     .Item(Txt) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To .Count + 1, 1 To 3)
c = 1
Ray(1, 1) = "Customer": Ray(1, 2) = "Platform": Ray(1, 3) = "Motor Category"

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .Keys
    [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] .Item(K)(0) & "," & .Item(K)(1)
        [COLOR="Navy"]Case[/COLOR] True & "," & True: Msg = "Multienergy"
        [COLOR="Navy"]Case[/COLOR] True & "," & False: Msg = "Conventional"
        [COLOR="Navy"]Case[/COLOR] False & "," & True: Msg = "Electric"
        [COLOR="Navy"]Case[/COLOR] Else: Msg = ""
    [COLOR="Navy"]End[/COLOR] Select
    [COLOR="Navy"]If[/COLOR] Not Msg = "" [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Ray(c, 1) = Split(K, ",")(0)
        Ray(c, 2) = Split(K, ",")(1)
        Ray(c, 3) = Msg
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("First 50 Programs").Range("A4").Resize(c, 2)
    .Value = Application.Index(Ray, Evaluate("Row(1:" & c & ")"), Array(1, 2))
    .Borders.Weight = 2
    .Columns.AutoFit
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("First 50 Programs").Range("E4").Resize(c)
    .Value = Application.Index(Ray, Evaluate("Row(1:" & c & ")"), 3)
    .Borders.Weight = 2
    .Columns.AutoFit
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Almost there! The code looks up the value in the sheet "Data" and returns the text in column "Motor Category" perfectly.

The only thing is that the list of customers and their relative platforms in the sheet "First 50 Programs" is fixed, it mustn't change.

Basically, the code should look up each combination of customer name + platform name of the sheet "First 50 Programs" in the sheet "Data" and return me the correspoding text in the column "Motor Category" based on the mentioned if-statements.

So, considering that in the sheet "First 50 Programs" the situation is as follows:

[TABLE="width: 400"]
<tbody>[TR]
[TD][/TD]
[TD]Column A[/TD]
[TD]Column B[/TD]
[TD]Column E[/TD]
[/TR]
[TR]
[TD]Row 4[/TD]
[TD]Customer[/TD]
[TD]Platform[/TD]
[TD]Motor Category[/TD]
[/TR]
[TR]
[TD]Row 5[/TD]
[TD]A[/TD]
[TD]1[/TD]
[TD]Multienergy[/TD]
[/TR]
[TR]
[TD]Row 6[/TD]
[TD]A[/TD]
[TD]2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Row 7[/TD]
[TD]A[/TD]
[TD]3[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Row 8[/TD]
[TD]B[/TD]
[TD]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Row 9[/TD]
[TD]B[/TD]
[TD]2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Row 10[/TD]
[TD]B[/TD]
[TD]3[/TD]
[TD]Electric[/TD]
[/TR]
[TR]
[TD]Row 11[/TD]
[TD]B[/TD]
[TD]4[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[/TR]
[TR]
[TD]Row 54[/TD]
[TD]Z[/TD]
[TD]1[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

when the code looks up the combination customer A + platform 1 in the sheet "Data" (here the column Customer is in the range J6:J50192 and the column Platform in P6:P50192), it returns in column E "Motor Category" the text Multienergy because for that customer's platform some programs have a motor type aa, some have bb, some have cc, some have dd and some have ee. Yet, for the platform 3 of the customer B, it returns Electric because that platform of that specific customer has programs only with a motor type ee.

Sorry if initially I didn't initially express the concept right and thank you for the taking the time to help me out.

Regards,
HS
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Jan02
'[COLOR="Green"][B]c2[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] A1 [COLOR="Navy"]As[/COLOR] Boolean, B1 [COLOR="Navy"]As[/COLOR] Boolean, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Msg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Rng50 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Data")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("J7", .Range("J" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
  [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
   .CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Txt = Dn.Value & "," & Dn.Offset(, 6).Value
    [COLOR="Navy"]If[/COLOR] Not .exists(Txt) [COLOR="Navy"]Then[/COLOR]
        A1 = False: B1 = False
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 53)
            [COLOR="Navy"]Case[/COLOR] "aa", "bb", "cc": A1 = True
            [COLOR="Navy"]Case[/COLOR] "ee": B1 = True
        [COLOR="Navy"]End[/COLOR] Select
        .Add Txt, Array(A1, B1, "")
    [COLOR="Navy"]Else[/COLOR]
      Q = .Item(Txt)
         [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 53)
             [COLOR="Navy"]Case[/COLOR] "aa", "bb", "cc": A1 = True
             [COLOR="Navy"]Case[/COLOR] "ee": B1 = True
         [COLOR="Navy"]End[/COLOR] Select
          Q(0) = A1
          Q(1) = B1
     .Item(Txt) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .Keys
    Q = .Item(K)
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Q(0) & "," & Q(1)
            [COLOR="Navy"]Case[/COLOR] True & "," & True:  Q(2) = "Multienergy"
            [COLOR="Navy"]Case[/COLOR] True & "," & False: Q(2) = "Conventional"
            [COLOR="Navy"]Case[/COLOR] False & "," & True: Q(2) = "Electric"
        [COLOR="Navy"]End[/COLOR] Select
    .Item(K) = Q
[COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]With[/COLOR] Sheets("First 50 Programs")
    [COLOR="Navy"]Set[/COLOR] Rng50 = .Range("A5", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng50
       Txt = Dn.Value & "," & Dn.Offset(, 1).Value
       [COLOR="Navy"]If[/COLOR] .exists(Txt) [COLOR="Navy"]Then[/COLOR] Dn.Offset(, 3).Value = .Item(Txt)(2)
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick,

Thanks a lot for your help! At the end, it works!

I needed to make a small change. By using your code, I didn't get a perfect match. The code returned the text Multienergy for some platforms that were supposed to be Electric.
By using the autofilter and setting the visible cells as range, it works. Funny is that I'm not really sure why :laugh:

Code: 
Sub Types_Of_Platforms()


Dim Rng As Range, Dn As Range, c As Range, Rng50 As Range
Dim n As Long, i As Long, lRow As Long
Dim A1 As Boolean, B1 As Boolean, Txt As String
Dim K As Variant, Msg As String, Q As Variant
Dim Dic As Object


lRow = Worksheets("First 50 Programs").Cells(Rows.Count, 2).End(xlUp).Row




For i = 5 To lRow
    Sheets("Data").Select
    With ActiveSheet.Range("$A$6:$EF$50192")
        .AutoFilter Field:=11, Criteria1:=Sheets("First 50 Programs").Range("A" & i).Value
        .AutoFilter Field:=16, Criteria1:=Sheets("First 50 Programs").Range("B" & i).Value
    End With
    
With Sheets("Data")
    Set Rng = .Range("J7:J50192").SpecialCells(xlCellTypeVisible)
End With
With CreateObject("scripting.dictionary")
   .CompareMode = vbTextCompare
    
For Each Dn In Rng
    Txt = Dn.Value & "," & Dn.Offset(, 6).Value
    If Not .exists(Txt) Then
        A1 = False: B1 = False
        Select Case Dn.Offset(, 53)
            Case "aa", "bb", "cc", "dd": A1 = True
            Case "ee": B1 = True
        End Select
        .Add Txt, Array(A1, B1, "")
    Else
      Q = .Item(Txt)
         Select Case Dn.Offset(, 53)
             Case "aa", "bb", "cc", "dd": A1 = True
             Case "ee": B1 = True
         End Select
          Q(0) = A1
          Q(1) = B1
     .Item(Txt) = Q
    End If
Next
For Each K In .Keys
    Q = .Item(K)
        Select Case Q(0) & "," & Q(1)
            Case True & "," & True:  Q(2) = "Multienergy"
            Case True & "," & False: Q(2) = "Conventional"
            Case False & "," & True: Q(2) = "Electric"
        End Select
    .Item(K) = Q
Next K


With Sheets("First 50 Programs")
    Set Rng50 = .Range("A5", .Range("A" & Rows.Count).End(xlUp))
End With
    For Each Dn In Rng50
       Txt = Dn.Value & "," & Dn.Offset(, 1).Value
       If .exists(Txt) Then Dn.Offset(, 3).Value = .Item(Txt)(2)
    Next Dn
End With


Next i


End Sub

Regards,
HS
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Vlookup formula that includes searching for specific criteria text within a group of cells
Replies
9
Views
431
AhoyNC
A
willow1985
  • Solved
Call a macro based on text in column C (same row that is active).
Replies
8
Views
119
6StringJazzer
6StringJazzer
T
  • Solved
Years visible only if there's a value in cell
Replies
6
Views
110
tigerzen
T
J
  • Solved
conditional formatting based on duplicate cells
Replies
4
Views
253
Joe4
Joe4
J
  • Question Question
copying adjacent cells based on value of referenced cell
Replies
4
Views
256
arun_eagertolearn
A

Forum statistics

Threads
1,223,886
Messages
6,175,198
Members
452,617
Latest member
Narendra Babu D

Share this page

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