Macro is required to the data filter

[harinsh]

Hi Excel Experts,

I am looking for one small automation macro to filter the data below and need to keep one set of data from the input to the output.

We have three columns below and Col-1 where "Y" is applicable in Col-3 then Col-1 cell value should be base and corresponding Col-2 data should copy against the value. Each corresponding value should paste in the different table (refer the output).

Table 1- Input

Col-1	Col-2	Col-3
10001	10011	Y
10011	10012
10003	10013	Y
10012	10014
10005	10015	Y
10014	10016
10007	10017	Y
10016	10018
10009	10019	Y
10018	10020

Table 2- Output

Output
Col-1	Col-2
10001	10001
10001	10011
10001	10012
10001	10014
10005	10015
10005	10016
10005	10018
10005	10020

Let me know if you need further clarification.

Thank you,

 

[Peter_SSs]

, is it possible to add even no hierarchy values as well something like this as one set? So, it will be clear that this value does not have any hierarchy.

Sure, it just requires the removal of two lines of the previous code.

Sub Hierarchy_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, Colm1 As Variant, Colm2 As Variant
  Dim i As Long, j As Long, k As Long
  
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("B2").End(xlDown).Offset(, 1)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 2)
  Next i
  ReDim b(1 To Rows.Count, 1 To 2)
  For i = 1 To UBound(a)
    If a(i, 3) = "Y" Then
      Colm1 = a(i, 1)
      Colm2 = a(i, 2)
'      If d.exists(Colm2) Then
        k = k + 1
        Do
          b(k, 1) = Colm1
          b(k, 2) = Colm2
          k = k + 1
          Colm2 = d(Colm2)
        Loop Until IsEmpty(Colm2)
'      End If
    End If
  Next i
  If k > 0 Then
    With Range("A1").End(xlDown).Offset(4)
      .Resize(k, 2).Value = b
      .Offset(-1).Resize(, 2).Value = Range("A1:B1").Value
    End With
  End If
End Sub

 

[harinsh]

It works very well only the last change I won't disturb anymore and your help highly appreciate and very helpful.

I want to keep same col-1 value should also keep at first level as like below highlighted what to be included in the code, sorry this was last moment change.

 

[Peter_SSs]

Do you want this added to the first code (post #9) or the second code (post #11)?

 

[harinsh]

Do you want this added to the first code (post #9) or the second code (post #11)?

The second time posted code is perfectly working after the removal of the if condition and this needs to be added to the same #11.

 

[Peter_SSs]

this needs to be added to the same #11.

In that case it sounds like you want this result (green cells to be added), not the one you showed in post #12?

harnish.xlsm
	A	B	C
1	Col-1	Col-2	Col-3
2	10001	10011	Y
3	10011	10012
4	10003	10013	Y
5	10012	10014
6	10005	10015	Y
7	10015	10016
8	10007	10017	Y
9	10016	10018
10	10009	10019	Y
11	10018	10020
12
13
14	Col-1	Col-2
15	10001	10001
16	10001	10011
17	10001	10012
18	10001	10014
19
20	10003	10003
21	10003	10013
22
23	10005	10005
24	10005	10015
25	10005	10016
26	10005	10018
27	10005	10020
28
29	10007	10007
30	10007	10017
31
32	10009	10009
33	10009	10019
Sheet1 (2)

 

[harinsh]

that's correct your output

 

[Peter_SSs]

that's correct your output

1. It is important that you give correct input/output in future. Multiple times in this thread you have given incorrect examples. Helpers will soon tire of helping you if they waste their time trying to do what you have asked, only to learn that you have not asked for the correct thing.
   
   
2. Also, I have already asked twice in this thread (now three times) for you to update your account details to include what Excel version(s) you are using as that can sometimes make a difference to the best way to do something.

 

[Peter_SSs]

Sub Hierarchy_v3()
  Dim d As Object
  Dim a As Variant, b As Variant, Colm1 As Variant, Colm2 As Variant
  Dim i As Long, j As Long, k As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("B2").End(xlDown).Offset(, 1)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 2)
  Next i
  ReDim b(1 To Rows.Count, 1 To 2)
  For i = 1 To UBound(a)
    If a(i, 3) = "Y" Then
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 1)
      Colm1 = a(i, 1)
      Colm2 = a(i, 2)
        k = k + 1
        Do
          b(k, 1) = Colm1
          b(k, 2) = Colm2
          k = k + 1
          Colm2 = d(Colm2)
        Loop Until IsEmpty(Colm2)
    End If
  Next i
  If k > 0 Then
    With Range("A1").End(xlDown).Offset(4)
      .Resize(k, 2).Value = b
      .Offset(-1).Resize(, 2).Value = Range("A1:B1").Value
    End With
  End If
End Sub

 

[harinsh]

Thank you very much Peter_SSs! It is working exactly as expected.

 

[Peter_SSs]

You're welcome.
(Pity we didn't ever find out what version you are using )