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: 17
  • Data.JPG
    Data.JPG
    157.2 KB · Views: 18

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,695
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Is your sheet protected or read only...
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,695
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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...

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

with this line

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

mlepesant

New Member
Joined
Jun 16, 2021
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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...

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

with this line

VBA Code:
.UsedRange.RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes
Done. Thank you!
 

mlepesant

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

ADVERTISEMENT

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.

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
Peter_SSs
I have run your code above and I am running into an error:
1623951363375.png
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,695
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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:

VBA Code:
Option Explicit

Sub Get_Data()
 Dim d As Object
 

mlepesant

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

ADVERTISEMENT

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:

VBA Code:
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

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,725
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

New Member
Joined
Jun 16, 2021
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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:
1623981468928.png


1623981440300.png
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
50,645
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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
 

Forum statistics

Threads
1,141,613
Messages
5,707,402
Members
421,508
Latest member
Jalayne

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