Need VBA help with complicate remaining part list task?

[motilulla]

Hello,

I need VBA help to find remaining list, which is a bit complicate task here below I have attempted to explain if not clear please ask question.

1-main part list M2:AF2 compares with row 4 item B2:J2 and result the remaining list in the cells M4:AF4...now here is the situation complicate, it must compare with row4+5 cells M4:AF5 both cells item with main part list M2:AF2 list and give the remain item list in the M5:AF5...it must do till all the item has been checked and finish from the main part list...no remaining...END.

2-then start new remaining lists calculation, and continues the same task for next rows till end of the item list find in the columns B:J

											Unique
	Item	Item	Item	Item	Item	Item	Item	Item	Item		Part List	12	27	32	75	86	90	98	100	107	124	137	138	139	140	145	152	157	210	242	249
	Sold	Sold	Sold	Sold	Sold	Sold	Sold	Sold	Sold
	12	32	86	90	124	145	157	210	242		Remaining	27	75	98	100	107	137	138	139	140	152	249
	32	86	100	107	137	139	152	242	249		Remaining	27	75	98	138	140
	27	75	86	90							Remaining	98	138	140
	100	107	124	145	152	242					Remaining	98	138	140
	98	107	145	210	242	249					Remaining	138	140
	12	98	138	140	242						End
	12	27	32								Remaining	75	86	90	98	100	107	124	137	138	139	140	145	152	157	210	242	249
	98	124	257								Remaining	75	86	90	100	107	137	138	139	140	145	152	157	210	242	249
	75	100	138	140	145	157	242	249			Remaining	86	90	107	137	139	152	210
	12	75	86	90	107	137	139	152	210		End
	152	249									Remaining	12	27	32	75	86	90	98	100	107	124	137	138	139	140	145	157	210	242
	107	124	137	139	140	157					Remaining	12	27	32	75	86	90	98	100	138	145	210	242

For example the sample image is attached.

Kind Regards
Moti

 

[Fluff]

How about

Sub motilulla()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nc As Long, m As Long
   Dim Flg As Boolean
   Dim Main As Object, Dic As Object
   
   Set Dic = CreateDic(Range("M2:AF2").Value2)
   Ary = Range("B4:J" & Range("B" & Rows.Count).End(xlUp).Row).Value2
   For r = 1 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         If Dic.Exists(Ary(r, c)) Then
            Dic.Remove Ary(r, c)
         End If
      Next c
      If Dic.Count > 0 Then
         Range("M3").Offset(r).Resize(, Dic.Count).Value = Dic.Keys
      Else
         Set Dic = CreateDic(Range("M2:AF2").Value2)
      End If
   Next r
End Sub
Function CreateDic(Ary As Variant) As Object
   Dim c As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   For c = 1 To UBound(Ary, 2)
      Dic(Ary(1, c)) = Empty
   Next c
   Set CreateDic = Dic
End Function

 

[motilulla]

How about

Sub motilulla()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nc As Long, m As Long
   Dim Flg As Boolean
   Dim Main As Object, Dic As Object
  
   Set Dic = CreateDic(Range("M2:AF2").Value2)
   Ary = Range("B4:J" & Range("B" & Rows.Count).End(xlUp).Row).Value2
   For r = 1 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         If Dic.Exists(Ary(r, c)) Then
            Dic.Remove Ary(r, c)
         End If
      Next c
      If Dic.Count > 0 Then
         Range("M3").Offset(r).Resize(, Dic.Count).Value = Dic.Keys
      Else
         Set Dic = CreateDic(Range("M2:AF2").Value2)
      End If
   Next r
End Sub
Function CreateDic(Ary As Variant) As Object
   Dim c As Long
   Dim Dic As Object
  
   Set Dic = CreateObject("scripting.dictionary")
   For c = 1 To UBound(Ary, 2)
      Dic(Ary(1, c)) = Empty
   Next c
   Set CreateDic = Dic
End Function

Fluff, I am speechless to see your great job!!!! I appreciate your help and enjoying your amazing solutions!!!

Thank you so much for your kind help!!! ?

I wish you good luck and happy time in your life.

Kind Regards
Moti

 

[Fluff]

Glad to help & thanks for the feedback.