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

KestutisTower

New Member
Joined
Jun 2, 2022
Messages
23
Office Version
  1. 2016
Platform
  1. Windows
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
ABC
1Burger
2Curry
3
4
5
6
7
8
meniu

and other (sheet2) with dish names and ingredients and amounts:
tantra meniu.xlsm
ABC
1DISHINGREDIANTAMOUNT
2Burgera1
3s2
4d3
5f4
6g5
7
8Curryz6
9a7
10d8
11t9
12h10
13f1
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
AB
1PRODUCTAMOUNT
2a1
3s2
4d3
5f4
6g5
7z6
8a7
9d8
10t9
11h10
12f1
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
ABC
1GROUPINGREDIENTAMOUNT
2
3DAIRYs
4f
5g
6
7
8DRYz
9h
10
11
12CANNEDa
13t
14d
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.
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

LazyBug

Board Regular
Joined
Feb 28, 2020
Messages
227
Office Version
  1. 2010
Platform
  1. Windows
Hello!

Try this (and pls check your worksheets names in my code):
VBA 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

New Member
Joined
Jun 2, 2022
Messages
23
Office Version
  1. 2016
Platform
  1. Windows
Hello!

Try this (and pls check your worksheets names in my code):
VBA 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

Board Regular
Joined
Feb 28, 2020
Messages
227
Office Version
  1. 2010
Platform
  1. Windows
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.
VBA Code:
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
 

Forum statistics

Threads
1,181,212
Messages
5,928,722
Members
436,625
Latest member
agholson81

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
Top