I have uploaded the program pretty much as it stands now to my website. The
link I will give you has the entire excel workbook and the VB code. I need
to change the code so that it returns more information and I am lost on how
to write the new code. Please download the workbook so you can follow along
and hopefully make suggestions.

Address:

www.entertainerdj.com/Rob.xls


Here's what I want to change:

I want to look at all the characters in the description instead of just the
first 10. Then, Take those characters and create an array of all the individual
charaters. First, I want to check the unit price for the item I am looking
at in sheets 1 - 7. Then I want to find ALL items with matching unit prices
in sheet 8. out of those entries, I want to look for the description in sheet
8 that contains the most matching characters to the array created from the
characters in the description being searched for. If the number of characters
in the description on sheet 8 that match the array from sheets 1 - 7 is less
than half of the total number of characters contained in the description
on page 8, I do not want to consider it a match, and will assume that the
part I am looking for does not reside on sheet 8, and the process will go
on to the next description writing nothing to the major and minor fields.



I will post the VB code here as well for easy reference. You will need to
see the entire workbook to follow what I am saying.

Thanks in advance for your input!

Code:

Public FindString As String, SearchRange As String, Value, FoundCell As Object

Public SearchRangeEnd As String, iCol As Integer, intSht As Integer, iRow
As Integer
Public AllRows As Integer, FoundRows As Integer
'--------------------------
'Takes info in first seven Spread Sheets and finds "matching"
'Info in 8th sheet
'The idea is to match either by part numbers or descriptions in the first
seven
'Sheets with Part Numbers or descriptions in the eighth sheet
'Then find minor and major headings describing where the parts are used
'And Inserting these minor/major headings into their respective rows in Sheets
1-7
'There are far fewer matches than had been hoped for.
'-------------------------------------------------------

Sub DoRob() 'Name of routine to do the above
AllRows = 0: FoundRows = 0 'Counters for how many we get
Application.ScreenUpdating = False 'Don't screw around waiting for the screen
to refresh, it takes too much time
SearchRangeEnd = ":F810" 'Last Cell to look in on sheet 8

i = 2 'Counter for listing results in Data, the first row is the heading

'Data is a spread sheet that shows the matches and where they came
from

For intSht = 1 To 7 'There are 7 worksheets with part Numbers we want to
locate
Sheets(intSht).Activate
Sheets(intSht).Range("G2:N659").Select 'Clear preavious results
Selection.Clear
Range("A2").Select 'and move cursor back to begining

Set FoundCell = Worksheets(8).Columns("A").Find("GBM") ' Initialize the
find object
SearchRange = "A2" & SearchRangeEnd 'Initial start point for each sheet


iRow = 3 'The First Row with partnumbers is 3 in all seven sheets

Do While Sheets(intSht).Cells(iRow, 1) > "" 'Part numbers are in column
1, keep chugging until part number is null
'Do part number search first
FindString = Sheets(intSht).Cells(iRow, 1) 'Column 1 is the part number
column
FoundPart = 0 'Set the Switch for deciding to look by description
'This should be another sub, but it works okay

If Left(FindString, 1) <> "*" Then 'The * is a wildcard for find so don't
even look if it's there
'The excel find routing sees ** as wild
cards it'll look forever it
'the string we start with begins with
an *
'Didn't plan on this happening, it should
be a separate sub,
'But **** happens

'+++++++++++++++++++++Search by part number in Column 1

FindString = Sheets(intSht).Cells(iRow, 1).Value 'Search by part
number in Column 1
l = Len(FindString) 'Get the length of the string
If l > 20 Then l = 20 'and check to see if it's longer than 20 characters

'Started with 15, but got a couple of illogical
matches inasmuch
'as the compared as equal, but did not logically
fit

FindString = Left(FindString, l) 'Get the first l characters, but
20 or less
Set FoundCell = Worksheets(8).Columns("A").Find("GBM") 'Keeps the
method Find from being Nothing at the start
iCol = 6 'Columns where we put the info less one
Do Until (FoundCell Is Nothing) 'Find all the strings in sheet(8)
that match
FindIt ' Go to this sub and see if we can locate FindString
If Not FoundCell Is Nothing Then 'Keep going until Nothing is
returned
FoundPart = 1 'Set the switch saying we found a part number

'Stuff the findings in a sheet called Data. This
will be helpful to see what's missing
Sheets("Data").Cells(i, 1) = FindString
Sheets("Data").Cells(i, 2) = iRow
Sheets("Data").Cells(i, 3) = Sheets(intSht).Name
Sheets("Data").Cells(i, 4) = "By Part Number"
Sheets("Data").Cells(i, 5) = FoundCell.Row
i = i + 1
MajorMinor 'Go do the major minor heading Thing now that
we've found something
End If
Loop 'Keep looping until we find all occurences of partnumber

'End of search by part number

'+++++++++++++++++++++Search by part Descripiton in Column 1

If FoundPart = 0 Then 'Check to see if we need to do by Description

'Do Search by description as necessary
SearchRange = "A2" & SearchRangeEnd 'Initial start point for this
sheet again
FindString = Sheets(intSht).Cells(iRow, 3).Value 'Search by description
in Column 3
DollarVal = Sheets(intSht).Cells(iRow, 5) 'Get ready to compare dollar
values
l = Len(FindString) 'Get the length of the string
If l > 10 Then l = 10 'and check to see if it's longer than 10 characters


FindString = Left(FindString, l) 'Get the first l characters, but
10 or less
Set FoundCell = Worksheets(8).Columns("A").Find("GBM") 'So it doesn't
start with NOTHING
Do Until (FoundCell Is Nothing) 'Find all that are there
FindIt 'Go to this sub and see if we can locate FindString
If Not FoundCell Is Nothing Then 'Keep going until NOTHING is
returnd

'Check to see if Amounts are equal
If DollarVal = Sheets(8).Cells(FoundCell.Row, 5).Value Then


Sheets("Data").Cells(i, 1) = FindString
Sheets("Data").Cells(i, 2) = iRow
Sheets("Data").Cells(i, 3) = Sheets(intSht).Name
Sheets("Data").Cells(i, 4) = "By Description"
Sheets("Data").Cells(i, 5) = FoundCell.Row
i = i + 1
MajorMinor
End If
End If
Loop ''Keep looping until we find all occurences of first 10 characters
of description
End If 'End if for deciding to do process by description
End If ' End if for checking to see if Part number starts with *
iRow = iRow + 1
FoundPart = 0 'Set this so we're ready to start with partnumber again

Loop 'For end of sheet
'The following three lines fits all the data to all the columns
Sheets(intSht).Activate
Sheets(intSht).Columns("A:N").Select
Selection.Columns.AutoFit
Application.ScreenUpdating = True 'Display sheet that's done
Sheets(intSht).Range("G1:H1").Select
Application.ScreenUpdating = False 'Turn it off so it doesn't hassle
us
iRow = iRow - 3
AllRows = AllRows + iRow
Next intSht 'For loop for all sheets
FoundRows = i - 1
Sheets(8).Activate 'Stop with Sheet1 displayed
Sheets(8).Range("G1:H1").Activate
Sheets(8).Range("G6").Value = "You have found " & FoundRows & " out of
" & AllRows & " Rows"
End Sub 'Stop for this sub
'-----------------------------
'This thing finds a string taken from sheets 1-7 and looks in sheet 8
'FindString is the string delivered to the sub
Sub FindIt()
Sheets(8).Activate
Set FoundCell = Sheets(8).Range(SearchRange).Find(FindString)
If Not FoundCell Is Nothing Then 'Get out when it finally fails

Sheets(8).Range(Cells(FoundCell.Row + 1, FoundCell.Column), Cells(FoundCell.Row
+ 1, FoundCell.Column)).Select
SearchRange = Selection.Address & SearchRangeEnd 'Keep changing
the search range so it won't eat itself up
Else
Exit Sub 'If it's Nothing then get out
End If
End Sub

'-----------------------------
Sub MajorMinor() 'Sub to find Major and minor Headings..headings are in yellow

m = FoundCell.Row
Do Until Sheets(8).Cells(m, 1).Interior.ColorIndex = 6 'Yellow is
6
m = m - 1
Loop
iCol = iCol + 1
Sheets(intSht).Cells(iRow, iCol) = Sheets(8).Cells(m, 1) 'Found First
heading; put it in Col 7
Do Until Sheets(8).Cells(m, 1).Interior.ColorIndex = 6 And _
Sheets(8).Cells(m - 1, 1).Interior.ColorIndex = 6 'Find
two yellows together
m = m - 1
Loop
iCol = iCol + 1
Sheets(intSht).Cells(iRow, iCol) = Sheets(8).Cells(m - 1, 1) 'Found
two yellows together and used the top one
'In
col8, if necessary 9 & 10, etc will be used

End Sub