VBA to find values in several columns, based on common value in a different column, then copy paste to different sheet

mlepesant

New Member
Joined
Jun 16, 2021
Messages
13
Office Version
  1. 365
Platform
  1. Windows
Hello,

New to the forum. Good excel skills but almost no VBA experience.

I have a file that provides me with Bill of material for different products. Each product can have up to 7 or 8 level of BOM.
On the attached pictures are data (data tab) and the result I am looking for (desired result tab).
For a given product in column B, I want to find values in columns M, V, AE, AN, AW, BF, and BO, and paste those values in a list (along with the following 2 columns after M, V, AE, AN, etc) on a separate sheet, then remove duplicates in column C of the separate sheet.
The loop would then go through all products in the data tab in column B and do the same. I have up to 25k rows.
Thank you for your help.
 

Attachments

  • Desired result.JPG
    Desired result.JPG
    199.3 KB · Views: 16
  • Data.JPG
    Data.JPG
    157.2 KB · Views: 16

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,657
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hi mlepesant- welcome to the Forum.

Does this come close to what you want to do. I am using "Sheet1" as the Data Sheet and "Sheet2" as the Results sheet. If the Results need to be on a different sheet, change the code where indicated. You will also have put your headers in on the results sheet in row 1(I could not read all the headers in your post, and I got lazy. The code will write the data starting in Cell A2. Additionally, I could not tell from your requested requirement if the last column was supposed to be Column AN + 2 as the "etc" you included was confusing. That said I only went out to Column AP. Run the code with the Data sheet as the active sheet.

(along with the following 2 columns after M, V, AE, AN, etc)

VBA Code:
Sub CopyNoDupesC()

    Dim arrB, arrData, arrRslt, rws
    Dim x As Long, i As Long, r As Long, nr As Long, a As Long

    arrB = Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)

    With CreateObject("Scripting.Dictionary")
        For x = LBound(arrB) To UBound(arrB)
            If Not IsMissing(arrB(x, 1)) Then .Item(arrB(x, 1)) = 1
        Next
        arrB = .Keys
    End With
    
    arrData = Range("B3:AP" & Cells(Rows.Count, "B").End(xlUp).Row)
    ReDim arrRslt(1 To UBound(arrData, 1), 1 To 14)
    rws = Array(1, 2, 12, 13, 14, 21, 22, 23, 30, 31, 32, 39, 40, 41)
    nr = 1
    For i = 0 To UBound(arrB)
        For a = 1 To UBound(arrData)
            If arrB(i) = arrData(a, 1) Then
                For r = 0 To 13
                    arrRslt(nr, r + 1) = arrData(a, rws(r))
                Next
                nr = nr + 1
            End If
        Next
    Next
    With Worksheets("Sheet2")  'Change Sheet Name Here
        .Range("A2").Resize(UBound(arrRslt, 1), UBound(arrRslt, 2)) = arrRslt
        .UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes
    End With
    MsgBox "Operation Complete"
    
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,453
Office Version
  1. 365
Platform
  1. Windows
Welcome to the MrExcel board!

For a given product in column B, ... on a separate sheet, ...
The loop would then go through all products in the data tab in column B and do the same.
I'm unsure whether this means to use the same "separate sheet" overwriting or appending the new data each time or whether each product goes to its own separate sheet. I have assumed the latter.
Also assumed
- that each product name makes a unique, valid, worksheet name and that these sheet names do not already exist in the workbook.
- original data on a sheet called 'Data'
- headings in 'Data' are in row 2 per your posted image
- no blank cells among the column B data

If any assumptions are incorrect then more details about that might allow for a modification to the code.

Some of my code is quite similar to igold's but this uses a lot less looping to fill the required array(s).
Test with a copy of your workbook.

VBA Code:
Sub Get_Data()
  Dim d As Object
  Dim a As Variant, aRws As Variant, aCols As Variant, Itm As Variant
  Dim lr As Long
  
  aCols = Split("2 3 13 14 15 22 23 24 31 32 33 40 41 42 49 50 51 58 59 60 67 68 69")  '<- Cols B, C, M, N, O, V, W, X, ..., BO, BP, BQ
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Data")
    lr = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    a = Application.Index(.Cells, Evaluate("row(3:" & lr & ")"), 2)
    For Each Itm In a
      d(Itm) = 1
    Next Itm
    Application.ScreenUpdating = False
    For Each Itm In d.Keys
      aRws = Filter(Application.Transpose(Evaluate(Replace("if(len(#),if(row(#)=2,2,if(#=""" & Itm & """,row(#),""x"")),""x"")", "#", .Columns(2).Resize(lr).Address(External:=True)))), "x", False)
      a = Application.Index(.Cells, Application.Transpose(aRws), aCols)
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = Itm
      Sheets(Itm).Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
      Sheets(Itm).UsedRange.RemoveDuplicates Columns:=2, Header:=xlYes
    Next Itm
    Application.ScreenUpdating = True
  End With
End Sub
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,657
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
@Peter_SSs - just doing a quick read of your code. I think the OP wants the dupes removed from Column C, your code may have it removing dupes from Column B.

VBA Code:
Sheets(Itm).UsedRange.RemoveDuplicates Columns:=2, Header:=xlYes
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,453
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

@Peter_SSs - just doing a quick read of your code. I think the OP wants the dupes removed from Column C, your code may have it removing dupes from Column B.

VBA Code:
Sheets(Itm).UsedRange.RemoveDuplicates Columns:=2, Header:=xlYes
You could be right but on re-reading I think we need some clarification from the OP, apart from the things already mentioned. Reason being the post says "For a given product in column B, I want to find values in columns M, V, ....", yet from the 'Data' image where columns M, V etc are highlighted, it appears that 'Products' may be listed in column C, not column B.

By my understanding of the description, column 3 in the result sheet corresponds to column M from the data sheet. Since that is the first column of the first of many sets of 3 columns it would seem a bit unusual to just remove duplicates using that column.
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,657
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
After reading Peters code, I have updated my code with some additional columns, as I missed that in your OP, which is what you meant with the etc.
As Peter suggested some additional clarification on your requirements is needed.



VBA Code:
Sub CopyNoDupesC()

    Dim arrB, arrData, arrRslt, rws
    Dim x As Long, i As Long, r As Long, nr As Long, a As Long

    arrB = Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)

    With CreateObject("Scripting.Dictionary")
        For x = LBound(arrB) To UBound(arrB)
            If Not IsMissing(arrB(x, 1)) Then .Item(arrB(x, 1)) = 1
        Next
        arrB = .Keys
    End With
    
    arrData = Range("B3:BQ" & Cells(Rows.Count, "B").End(xlUp).Row)
    ReDim arrRslt(1 To UBound(arrData, 1), 1 To 23)
    rws = Array(1, 2, 12, 13, 14, 21, 22, 23, 30, 31, 32, 39, 40, 41, 48, 49, 50, 57, 58, 59, 66, 67, 68)
    nr = 1
    For i = 0 To UBound(arrB)
        For a = 1 To UBound(arrData)
            If arrB(i) = arrData(a, 1) Then
                For r = 0 To 22
                    arrRslt(nr, r + 1) = arrData(a, rws(r))
                Next
                nr = nr + 1
            End If
        Next
    Next
    With Worksheets("Sheet2")  'Change Sheet Name Here
        .Range("A2").Resize(UBound(arrRslt, 1), UBound(arrRslt, 2)) = arrRslt
        .UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes
    End With
    MsgBox "Operation Complete"
   
End Sub
 

mlepesant

New Member
Joined
Jun 16, 2021
Messages
13
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thank you very much igold and Peter_SSs.

I have not run the codes yet for I wanted to answer your questions first. Sorry, it is my first time posting here.
What I am looking for is from the Data sheet, look first for the value in Column B, then copy this value, with the corresponding description in column C (so in my case MXXX1 in column B, and Product A, in column C), create a new sheet and paste them into this new sheet. Then for each value in Column B, find the values in columns "M, N, O"; "V, W, X"; "AE, AF, AG"; "AN, AO, AP"; "AW, AX, AY"; "BF, BG, BH"; "BO, BP, BQ". Copy those values in cells C, D, E of the new sheet.
Then remove duplicates based on the couple Column A / Column C.
Then move to the next product in the data sheet in Column B. (in my case MXXX2)
I assume you could remove duplicates at the end, but I poorly explained what I meant by that previously. Removing duplicates should not be based on Column C alone, but again, based on Column A and Column C. In other words, in the results sheet (sheet added) I can have a couple MXXX1 / C09801, but not 2. However I can have MXXX1 / C09801 and MXXX2 / C09801.
I hope it clarifies things.
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,657
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
I am unclear as to how many new sheets you want... One for each item or one sheet with all your items with the dupes as described removed...
 

mlepesant

New Member
Joined
Jun 16, 2021
Messages
13
Office Version
  1. 365
Platform
  1. Windows
I have ran the last code provided by igold, I am running into an error as follows:

1623945531917.png
 

mlepesant

New Member
Joined
Jun 16, 2021
Messages
13
Office Version
  1. 365
Platform
  1. Windows
I am unclear as to how many new sheets you want... One for each item or one sheet with all your items with the dupes as described removed...
Aghh sorry. Just one sheet, for all products. Not one per product.
 

Forum statistics

Threads
1,136,772
Messages
5,677,637
Members
419,707
Latest member
Anna vib

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