Loop through multiple named ranges to find match and copy paste that range

[KestutisTower]

Hello you great bunch! First, I want to express my appreciation to this forum and to you guys. You'v been a great help along my way. Learned SO much. Huge thanks!!!

And now to my question. I have one sheet (sheet1)with dish names (this is example):

tantra meniu.xlsm
	A	B	C
1	Burger
2	Curry
3
4
5
6
7
8
meniu

and other (sheet2) with dish names and ingredients and amounts:

tantra meniu.xlsm
	A	B	C
1	DISH	INGREDIANT	AMOUNT
2	Burger	a	1
3		s	2
4		d	3
5		f	4
6		g	5
7
8	Curry	z	6
9		a	7
10		d	8
11		t	9
12		h	10
13		f	1
receptai

I need a way to compare values in column A in sheet1 with values in column A in sheet2 and if mach is made, copy paste next two columns of dish matched to sheet3 A:B columns.
so it looks like this:

tantra meniu.xlsm
	A	B
1	PRODUCT	AMOUNT
2	a	1
3	s	2
4	d	3
5	f	4
6	g	5
7	z	6
8	a	7
9	d	8
10	t	9
11	h	10
12	f	1
13
pirkiniai

and if there would be more matches, it would be copied in first empty row in sheet3.
The only way I can imagine MAYBE to do this is to create a named range for each dish and to look for name of that dish in them to make mach (ranges would have same name as dish name).
OR ideally, to match the ingredients from matched dishes in sheet2 with the ingredients in sheet4 and if match is made to copy paste amount values (if multiple matches, to sum them up).This is sheet4:

tantra meniu.xlsm
	A	B	C
1	GROUP	INGREDIENT	AMOUNT
2
3	DAIRY	s
4		f
5		g
6
7
8	DRY	z
9		h
10
11
12	CANNED	a
13		t
14		d
15
sarasas

I hope my question is clear and makes sense. I understand this is kind of double question, but it would lead to same solution at the end. Thanks for any help in advance.

 

[LazyBug]

Hello!

Try this (and pls check your worksheets names in my code):

Sub kt()
Dim d As Object, r, i
    Set d = CreateObject("scripting.dictionary")
    With d
        For Each r In Worksheets("receptai").Columns(2).SpecialCells(2).Areas
            For i = 1 To r.Rows.Count
               .Item(.Count) = Application.Index(r.Resize(, 2), i, 0)
            Next i
        Next r

        Worksheets("purkiniai").Cells(1, 1).Resize(.Count, 2) = Application.Index(.items, 0, 0)
        .RemoveAll
   
        r = Worksheets("purkiniai").Cells(2, 1).CurrentRegion.Value
        For i = 2 To UBound(r)
            .Item(r(i, 1)) = .Item(r(i, 1)) + r(i, 2)
        Next i
        i = ""
       
        With Worksheets("sarasas")
            For Each r In .Range("B3:B" & .Range("B3").SpecialCells(11).Row)
                If Not IsEmpty(r) Then
                    For Each i In d.keys
                        If r = i Then r(1, 2) = d(i)
                    Next i
                End If
            Next r
         End With
    End With
End Sub

 

[KestutisTower]

Hello!

Try this (and pls check your worksheets names in my code):

Sub kt()
Dim d As Object, r, i
    Set d = CreateObject("scripting.dictionary")
    With d
        For Each r In Worksheets("receptai").Columns(2).SpecialCells(2).Areas
            For i = 1 To r.Rows.Count
               .Item(.Count) = Application.Index(r.Resize(, 2), i, 0)
            Next i
        Next r

        Worksheets("purkiniai").Cells(1, 1).Resize(.Count, 2) = Application.Index(.items, 0, 0)
        .RemoveAll
  
        r = Worksheets("purkiniai").Cells(2, 1).CurrentRegion.Value
        For i = 2 To UBound(r)
            .Item(r(i, 1)) = .Item(r(i, 1)) + r(i, 2)
        Next i
        i = ""
      
        With Worksheets("sarasas")
            For Each r In .Range("B3:B" & .Range("B3").SpecialCells(11).Row)
                If Not IsEmpty(r) Then
                    For Each i In d.keys
                        If r = i Then r(1, 2) = d(i)
                    Next i
                End If
            Next r
         End With
    End With
End Sub

Hello LazyBug. Thanks for the code! It kind of does something what I need, except it copies all the things from sheet2("receptai") and pastes in sheets 3 and 4 . I need to copy only products from the recepie that is listed in sheet1 ("meniu"). it will not necessary always be all of the recipes. It could be just one of them.

 

[LazyBug]

Hello! Here is corrected version, but before that a few important notes for sheet "receptai". Macro will work only after fixing it.
1. all column A joined cells must be unmerged and fill in.
2. delete empty rows.

Sub kt2()
Dim m(), r, a, i, j, c&
Dim d As Object

    m = Worksheets("meniu").Range("A1").CurrentRegion.Value
    With Worksheets("receptai")
        r = .Range(.Range("A2"), .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row)).Resize(, 3).Value
    End With
    
    ReDim a(1 To UBound(r), 1 To 2)

    For i = 1 To UBound(r)
        For j = 1 To UBound(m)
            Select Case r(i, 1)
                Case m(j, 1)
                    c = c + 1
                    a(c, 1) = r(i, 2): a(c, 2) = r(i, 3)
            End Select
        Next j
    Next i

    With Worksheets("purkiniai")
        .Range("A1").CurrentRegion.Offset(1).ClearContents
        .Range("A2").Resize(c, 2) = a
    End With
    
    Set d = CreateObject("scripting.dictionary")
        With d
            a = Worksheets("purkiniai").Range("A2").CurrentRegion.Value
            If Not IsEmpty(a) Then
                For i = 2 To UBound(a)
                    .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2)
                Next
            End If
            
            With Worksheets("sarasas")
                .Range("C3:C" & .Range("C3").SpecialCells(11).Row).ClearContents
                For Each r In .Range("B3:B" & .Range("B3").SpecialCells(11).Row)
                    If Not IsEmpty(r) Then
                        For Each i In d.keys
                            If r = i Then r(1, 2) = d(i)
                        Next i
                    End If
                Next r
             End With
        End With
End Sub