Find all values that match anything in a range

[Digilypse]

I just learned how to add in Excel a couple months ago and, although I'm doing the best I can with google, VBA is not easy for me to work with yet. So, while I certainly appreciate any sort of help, explanation-heavy answers would be doubly appreciated!

The excel file I've attached should explain it far more clearly than I can in words, but I'll try to summarize. I need to take a selection of cells and insert them into a table wherever text from a range show up.

Now, I should be - and have been - able to select the cells I want to insert and use the find method to find where to put them. Basically, find all instances of "packageA" and insert; I have a macro for this in the example worksheet. The problem is, I have a lot of different things to find. It needs to also insert on all the packageB's and C's and so on for a good 50 more, AND more are being added continuously. So, I can't just duplicate the macro for packageB and be done with it.

Here's what I'm using to find and insert:

Sub FindandInsert()


Dim rFoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String




Sheets("Sheet3").Select


With Range("B1:B1195")
    Set LastCell = .Cells(.Cells.Count)
End With
Set rFoundCell = Range("B1:B1195").Find(What:="PackageA", After:=LastCell)




If Not rFoundCell Is Nothing Then
    FirstAddr = rFoundCell.Address
End If
Do Until rFoundCell Is Nothing
    Debug.Print rFoundCell.Address
    
    Set rFoundCell = Range("B1:B1195").FindNext(After:=rFoundCell)
    
    Range("InsertRange").Copy
        
    rFoundCell.Select
        Selection.Offset(0, -1).Insert Shift:=xlDown
    
    If rFoundCell.Offset(-4, 0).Address = FirstAddr Then
        Exit Do
    End If
Loop


End Sub

Simply, instead of using find method to find one thing, I need to find anything that is in a range.

I imagine I can figure out this next part on my own eventually, but, after it's done doing that it needs to go back through and clear out blank rows. Some of the inserts leave one or several blank rows at the top, depending on which type of package they have been inserted on top of.

Seems like it should be so simple but I've spent ages without figuring it out...guess I need more grounding in VBA first.

Crossposted with example file here: http://www.ozgrid.com/forum/showthread.php?t=164129

 

[pbornemeier]

Is there a different "Input range" specified for each search term (package)?
If so, is there a table that matches each package to its "Input Range" address?
Is the "Input Range" more than 1 column wide?
Do any of the inserted rows contain values in column B that would be insertmarkers for subsequent packages?

 

[Digilypse]

InputRange is a set of Index+match formulas which look at the line below it and match with a table on another sheet. So, there is one InputRange for all of the packages.

The InputRange is 4 rows x 6 columns, the same number of columns as the table it is being inserted into. If the package has 4 kinds of items in it, all 4 rows load; if it has 3 kinds of items, 3 rows load and the 4th on top is Iferror="". B is the second column in the table, which is why I have it offset to the left when it inserts.

Come to think of it, there is a possibility that InputRange might load other sortmakers (if one package type contained other packages) which should not be loaded. I could get around this by finding a special way to handle those particular packages if necessary, but if there is a way around it, that would be extremely convenient.

 

[Digilypse]

Wait, disregard that last part. I'll have to handle the package-in-package thing separately for another reason anyway. So no, nothing that would be an insertmaker for subsequent packages.

 

[Digilypse]

Here is the InsertRange:

Excel Workbook
	C	D	E	F	G	H
2	INSERT	*	*	*	*	*
3	*	*	0	0	0	*
4	*	#N/A	#N/A	#N/A	#N/A	#N/A
5	*	#N/A	#N/A	#N/A	#N/A	#N/A
6	*	#N/A	#N/A	#N/A	#N/A	#N/A
Sheet4

Excel Workbook
	C	D	E	F	G	H
2	INSERT	*	*	*	*	*
3	12/4/2012	Lidget	15.26	5842.45286	7010.94343	229.71636
4	12/4/2012	Bidget	0.26	4645.37536	5574.45044	10720.097
5	12/4/2012	Tridget	1.62	11164.2153	13397.0584	4134.8946
6	12/4/2012	Widget	7.62	58347.9565	70017.5478	4594.3273
7	12/4/2012	packagea	2	40000	48000	24000
Sheet4

Excel Workbook
	C	D	E	F	G	H
3	*	*	*	*	*	*
4	12/4/2012	Lidget	26.28	7674.48652	9209.38382	175.21659
5	12/4/2012	Fidget	26	21512.7032	25815.2438	496.447
6	12/4/2012	Gidget	58	50812.8103	60975.3723	525.64976
7	12/4/2012	packageb	2	40000	48000	24000
Sheet4

 

[Digilypse]

And here is the table where the InsertRange is to be inserted, and the table with the info for the packages

Excel Workbook
	A	B	C	D	E	F
1	Date	Items Bought	Quantity	Price	Fees	Per Item
2	3/28/2012	PackageA	1	11,500	12950	12,950
3	3/29/2012	PackageB	1	22,000	25115	25,115
4	3/30/2012	PackageB	3	66,000	75345	25,115
5	3/31/2012	Widget	1	1,600	1600	1,600
6	4/1/2012	Widget	1	1,000	1000	1,000
7	4/2/2012	Bidget	1	400	400	400
8	4/3/2012	Gidget	46	1,058	1058	23
9	4/4/2012	Tridget	1	600	600	600
10	4/5/2012	Widget	1	300	300	300
11	4/6/2012	Widget	1	250	250	250
12	4/7/2012	PackageA	1	20,000	21450	21,450
13	4/8/2012	Widget	1	1,500	1500	1,500
14	4/9/2012	Tridget	1	250	250	250
15	4/10/2012	Widget	1	1,240	1240	1,240
Sheet3

Excel Workbook
	C	D	E	F	G
14	*	*	Quantity(averaged)	Can Sell for	% of package value
15	PackageA	Widget	3.81	6000	73%
16	PackageA	Tridget	0.81	5400	14%
17	PackageA	Bidget	0.13	14000	6%
18	PackageA	Lidget	7.63	300	7%
19	*	*	*	*	*
20	PackageB	Gidget	29	900	64%
21	PackageB	Fidget	13	850	27%
22	PackageB	Lidget	13.14	300	10%
Sheet4

 

[pbornemeier]

I added the PackageInsert keywords on Sheet5:

Excel Workbook
	A
1	Insert Values
2	PackageA
3	PackageB
4	PackageC
5	PackageD
Sheet5

and a dynamic named range called Insert_Values which is set to:
=OFFSET(Sheet5!$A$1,1,0,COUNTA(Sheet5!$A:$A)-1,1)

This code seems to do what you want, but I don't quite follow what the formulas in the input block are doing, so I cannot be sure.

Option Explicit

Sub FindandInsert()

  Dim lActiveRow As Long
  Dim vInsertValues() As Variant
  Dim lX As Long
  Dim lY As Long
  
  With Sheets("Sheet3")
  
    'Find the last populated cell in column B (2)
    lActiveRow = .Cells(Rows.Count, 2).End(xlUp).Row
    
    'Get the named range into an array in memory
    vInsertValues() = ThisWorkbook.Sheets(5).Range("Insert_Values").Value
    
    For lX = lActiveRow To 2 Step -1 'Start from the bottom of the data so no lines are missed
      For lY = LBound(vInsertValues()) To UBound(vInsertValues()) 'Check each element of the 'Insert Values' range
        If UCase(.Cells(lX, 2).Value) = UCase(vInsertValues(lY, 1)) Then
          'Debug.Print "Active Row=" & lX, lY, vInsertValues(lY, 1)
          'Stop
          Range("InsertRange").Copy
          .Cells(lX, 2).Offset(0, -1).Insert Shift:=xlDown
          
          'If the inserted values in column A are supposed to be dates uncomment this line:
          '.Range(Cells(lX, 1), Cells(lX + 3, 1)).NumberFormat = "m/d/yyyy"
        End If
      Next
    Next
  End With
  
End Sub

Sub DeleteBlankRows()

  'Not sure if this will be needed
  'Convert all formulas to text
  'With Worksheets("Sheet3").Range("A1").CurrentRegion
  '  .Value = .Value
  'End With
  
  'Filter for blanks in column C; delete visible rows
  With Worksheets("Sheet3")
    .AutoFilterMode = False 'Turn off autofilter to ensure nothing is filtered
    .Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:="=" 'look for blanks in column C
    'If there are any visible cells in column A, other than the 1 header row
    'select all cells, less the top row, that are visible and delete the rows containing them
    If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then _
      .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilterMode = False 'Turn off autofilter
  End With
  
End Sub

Let me know what is not working if there is a problem.

 

[Digilypse]

Oh, wow. That works PERFECTLY. After hours of trying to get this project working only to get stuck on this one piece, it feels amazing to see everything flowing and matching up just like I imagined. Thank you so much!!