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

[mlepesant]

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.

 

[igold]

Is your sheet protected or read only...

 

[mlepesant]

Is your sheet protected or read only...

No

 

[igold]

I am trying to figure out why you are getting that error. In the mean time to get the correct dupes removed, please replace this line. This line is the third up from the bottom...

 .UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes

with this line

.UsedRange.RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes

 

[mlepesant]

I am trying to figure out why you are getting that error. In the mean time to get the correct dupes removed, please replace this line. This line is the third up from the bottom...

 .UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes

with this line

.UsedRange.RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes

Done. Thank you!

 

[mlepesant]

Welcome to the MrExcel board!


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.

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

Peter_SSs
I have run your code above and I am running into an error:

 

[igold]

I am not sure it will help anything but it definitely will not hurt... Try inserting the words "Option Explicit" (sans quotes) at the top of each code above the name of the code. So in your post #15 it would read as:

Option Explicit

Sub Get_Data()
 Dim d As Object

 

[mlepesant]

I am not sure it will help anything but it definitely will not hurt... Try inserting the words "Option Explicit" (sans quotes) at the top of each code above the name of the code. So in your post #15 it would read as:

Option Explicit

Sub Get_Data()
 Dim d As Object

I inserted in each of the codes. It does not change anything.
I still have the same errors.

 

[Domenic]

With regards to Post #9, the line you've set as a breakpoint seems fine. Therefore, can you please confirm which line is giving you that error?

 

[mlepesant]

With regards to Post #9, the line you've set as a breakpoint seems fine. Therefore, can you please confirm which line is giving you that error?

Yes, from post #9 I confirm that this is the line giving the error:

 

[Peter_SSs]

Then move to the next product in the data sheet in Column B. (in my case MXXX2)

It is not clear what to do with this second and subsequent product. Does it get appended to the bottom of the first product data in the results sheets or does it replace? I have assumed appended at the bottom.

It now seems to me that you want all the rows from Data moving to Results, but only those specific columns. If we then sort the data appropriately and remove duplicates (columns A & C on the Result sheet), would we have what you want?

Could you also confirm (if the code below does not do what you want) whether those headings on the Data sheet are actually in row 2 or row 1. I am now assuming that they are actually in row 1 and you just moved them down so that you could show us with the green and yellow in row 1 of the image in post #1which columns toy wanted extracted.

I am also assuming a 'Result' sheet exists and that it is empty or any data in it can be removed. Please advise details if this is not correct.

I could be way off the mark but this is what I am thinking.

Sub Get_Data_v2()
  Dim aCols 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
  Application.ScreenUpdating = False
    lr = Sheets("Data").Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Sheets("Result")
      .UsedRange.ClearContents
      .Range("A1").Resize(lr, UBound(aCols) + 1).Value = Application.Index(Sheets("Data").Cells, Evaluate("row(1:" & lr & ")"), aCols)
      With .UsedRange
        .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(3), Order2:=xlAscending, Header:=xlYes
        .RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes
      End With
    End With
  Application.ScreenUpdating = True
End Sub