Code by Claus that looked up four items and returned a fifth item.

I need it to lookup three and return the fourth.

First item is in column B6:B500+-
Second is in column C same range
Third is in column D same range

and the return item is in column H same range as others.

Items 1 thru 4 will be on the same row.

I have made some change to the original code but to dense to get it to look for three return fourth.

The message box is good and M9, 10, 11 etc. are fine for a return targets at present.

Thanks.
Howard


Option Explicit
Option Compare Text

Sub Lookup_Four_Return_Fifth2_Claus()
'// Lookup three return fourth
Dim lngLstRow As Long
Dim str1 As String
Dim str2 As String
Dim i As Long

Dim intVStore() As Double

Dim intValVar As Integer
Dim wsh As Worksheet

str1 = InputBox("Input Material:", "Material") & InputBox("Input Pipe Non. Diameter:", "Pipe Nom Dia") _
& InputBox("Input Pipe Press Class:", "Pipe Press Cls")

For Each wsh In ThisWorkbook.Worksheets

With wsh
lngLstRow = .UsedRange.Rows.Count

For i = 2 To lngLstRow

str2 = .Cells(i, 1) & .Cells(i, 2) & _
.Cells(i, 3)

If StrComp(str1, str2, 1) = 0 Then

ReDim Preserve intVStore(intValVar)
intVStore(intValVar) = .Cells(i, 7).Value

Range("K1") = .Cells(i, 2) & " " & .Cells(i, 3) & " " & _
.Cells(i, 4)
Range("K2") = intVStore() 'Price

intValVar = intValVar + 1
End If
Next

End With

Next wsh

If intValVar = 0 Then
MsgBox "No items found"
Exit Sub
Else
'MsgBox "The Price is: " & WorksheetFunction.Max(intVStore())
End If
End Sub

Hi Howard,

Am Mon, 14 Oct 2013 04:49:52 -0700 (PDT) schrieb Howard:

First item is in column B6:B500+-
Second is in column C same range
Third is in column D same range

and the return item is in column H same range as others.

for maximum price in K2:

Sub Lookup_Four_Return_Fifth2_Claus()
'// Lookup three return fourth
Dim lngLstRow As Long
Dim str1 As String
Dim str2 As String
Dim i As Long

Dim intVStore() As Double
Dim intValVar As Integer
Dim wsh As Worksheet

str1 = InputBox("Input Material:", "Material") & InputBox("Input Pipe
Non. Diameter:", "Pipe Nom Dia") _
& InputBox("Input Pipe Press Class:", "Pipe Press Cls")

For Each wsh In ThisWorkbook.Worksheets

With wsh
lngLstRow = .UsedRange.Rows.Count
For i = 6 To lngLstRow
str2 = .Cells(i, 2) & .Cells(i, 3) & _
.Cells(i, 4)
If StrComp(str1, str2, 1) = 0 Then
ReDim Preserve intVStore(intValVar)
intVStore(intValVar) = .Cells(i, 8).Value

Range("K1") = .Cells(i, 2) & " " & .Cells(i, 3) & " " & _
.Cells(i, 4)
intValVar = intValVar + 1
End If
Next
End With

Next wsh

If intValVar = 0 Then
MsgBox "No items found"
Exit Sub
Else
Range("K2") = WorksheetFunction.Max(intVStore())
End If
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Worked fine with the return on the same sheet as the code is in.

I changed it to read out on another worksheet and that seems to work just fine also!!

Thanks Claus.

Regards,
Howard

Hi Howard,

Am Mon, 14 Oct 2013 06:38:25 -0700 (PDT) schrieb Howard:

I changed it to read out on another worksheet and that seems to work just fine also!!

I don't know whether you want all found items, the max price or the min
price
So I adapted it to the existing code with the max


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Monday, October 14, 2013 7:03:47 AM UTC-7, Claus Busch wrote:
Hi Howard,



Am Mon, 14 Oct 2013 06:38:25 -0700 (PDT) schrieb Howard:



I changed it to read out on another worksheet and that seems to work just fine also!!



I don't know whether you want all found items, the max price or the min

price

So I adapted it to the existing code with the max





Regards

Claus B.


The fourth item to be returned is a single measurement such as 308.25, so I don't think the max or min are relevant. But I have to admit I am lost on the min or max.

I do want the three criteria and of course the fourth item to be listed, which it does nicely. So is that the Max as you have mentioned?

It is working fine, although the fourth item is a bit slow to be listed. A few second, which I believe is okay, given the 500 +/- rows.

The input box items pop right up, no problem.

Howard

Hi Howard,

Am Mon, 14 Oct 2013 08:51:16 -0700 (PDT) schrieb Howard:

The fourth item to be returned is a single measurement such as 308.25, so I don't think the max or min are relevant. But I have to admit I am lost on the min or max.

I do want the three criteria and of course the fourth item to be listed, which it does nicely. So is that the Max as you have mentioned?

It is working fine, although the fourth item is a bit slow to be listed. A few second, which I believe is okay, given the 500 +/- rows.

there could be more than one found strings and the array is filled with
all found items. At the moment you get the max(Array).


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

Am Mon, 14 Oct 2013 08:51:16 -0700 (PDT) schrieb Howard:

It is working fine, although the fourth item is a bit slow to be listed. A few second, which I believe is okay, given the 500 +/- rows.

please try this version (You have to modify the output range)
It is a bit faster:

Sub Test()
Dim lngLstRow As Long
Dim str1 As String, str2 As String, str3 As String
Dim strTotal As String, str4 As String
Dim i As Long
Dim n As Long
Dim varIn() As Variant
Dim varout() As Double
Dim wsh As Worksheet
Dim st As Double



str1 = InputBox("Input Material:", "Material")
str2 = InputBox("Input PipeNon. Diameter:", "Pipe Nom Dia")
str3 = InputBox("Input Pipe Press Class:", "Pipe Press Cls")
strTotal = str1 & str2 & str3
st = Timer
For Each wsh In ThisWorkbook.Worksheets
With wsh
lngLstRow = .Cells(.Rows.Count, 2).End(xlUp).Row
varIn = .Range("B6:H" & lngLstRow)
For i = LBound(varIn) To UBound(varIn)
str4 = varIn(i, 1) & varIn(i, 2) & varIn(i, 3)
If StrComp(strTotal, str4, 1) = 0 Then
ReDim Preserve varout(n)
varout(n) = varIn(i, 7)
n = n + 1
End If
Next
End With
Next
[K1] = str1 & " " & str2 & " " & str3
[K2] = WorksheetFunction.Max(varout)
MsgBox Format(Timer - st, "0.000")
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2