Convert code to lookup three criteria return fourth

H

Howard

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
 
C

Claus Busch

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.
Click to expand...

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.
 
H

Howard

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
 
C

Claus Busch

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!!
Click to expand...

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.
 
H

Howard

Hi Howard,



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






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.
Click to expand...

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
 
C

Claus Busch

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.
Click to expand...

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.
 
C

Claus Busch

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.
Click to expand...

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.
 
H

Howard

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.
Click to expand...

Wow! Yes indeed, a lot faster!

Many thanks, Claus.

Regards,
Howard
 
H

Howard

Hi Claus,

I am trying to incorporate an error catcher similar to the one in the previous code, but alas, I can't sort out the equivalent of "If intValVar = 0 Then" in the new faster code.

If intValVar = 0 Then
MsgBox "No items found"
Exit Sub
Else

Sheets("Darcy-Weisbach").Range("F6") = WorksheetFunction.Max(intVStore())
End If

Thanks.

Howard
 
C

Claus Busch

Hi Howard,

Am Mon, 14 Oct 2013 13:04:20 -0700 (PDT) schrieb Howard:
I am trying to incorporate an error catcher similar to the one in the previous code, but alas, I can't sort out the equivalent of "If intValVar = 0 Then" in the new faster code.

If intValVar = 0 Then
MsgBox "No items found"
Exit Sub
Else

Sheets("Darcy-Weisbach").Range("F6") = WorksheetFunction.Max(intVStore())
End If
Click to expand...

try:
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

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
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
If n = 0 Then
MsgBox "No items found"
Exit Sub
Else
Sheets("Darcy-Weisbach").Range("F6") = WorksheetFunction.Max(varOut)
End If
End Sub


Regards
Claus B.
 
H

Howard

Okay, thanks, I'll give that a try with much confidence.

And why would I get a Type mismatch error if I wanted the option to define the three search strings from cell references (drop downs).

str2 is a number, 40, 125, 60 etc. but is accepted as a string from the input box.
The values in the drop down are identical to the values entered into the input boxes...?

str1 = Range("C5").Value
str2 = Range("D5").Value
str3 = Range("E5").Value

Howard
 
C

Claus Busch

Hi Howard,

Am Mon, 14 Oct 2013 13:55:22 -0700 (PDT) schrieb Howard:
str2 is a number, 40, 125, 60 etc. but is accepted as a string from the input box.
The values in the drop down are identical to the values entered into the input boxes...?
Click to expand...

for me it works with numbers
But try changing .value to .text


Regards
Claus B.
 
H

Howard

for me it works with numbers
But try changing .value to .text
Click to expand...
Regards

Claus B.
Click to expand...

Here is what my attempt looks like, I wasn't getting the error before I went to cell references, so that is why I guess it has to do with my changes.

I did make a change to return the results to two pages, and that works just fine.

Howard

Option Explicit
Option Compare Text

Sub TestClausDropDown()
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 = Range("C5").Text
str2 = Range("D5").Text
str3 = Range("E5").Text

'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

Sheets("Darcy-Weisbach").Range("F5") = str1 & " " & str2 & " " & str3
[O2] = str1 & " " & str2 & " " & str3
Sheets("Darcy-Weisbach").Range("F6") = WorksheetFunction.Max(varOut)
[P2] = WorksheetFunction.Max(varOut)
MsgBox Format(Timer - st, "0.000")
End Sub
 
C

Claus Busch

Hi Howard,

Am Mon, 14 Oct 2013 14:18:15 -0700 (PDT) schrieb Howard:
Here is what my attempt looks like, I wasn't getting the error before I went to cell references, so that is why I guess it has to do with my changes.
Click to expand...

I only get an error if no items are found. Therefore try the
IF-statemant:

If n = 0 Then
MsgBox "No items found"
Else
Sheets("Darcy-Weisbach").Range("F5") = str1 & " " & str2 & " " & str3
[O2] = str1 & " " & str2 & " " & str3
Sheets("Darcy-Weisbach").Range("F6") = WorksheetFunction.Max(varOut)
[P2] = WorksheetFunction.Max(varOut)
End If


Regards
Claus B.
 
H

Howard

Or another way to make it work IS TO PUT IT IN A STANDARD MODULE.

Sometimes I think there is no hope for me.

Sorry, Claus for all the trouble, that sure seems to be a bad habit of mine not using a standard module.

Thanks, and again, I'm sorry.

Regards
Howard
 
C

Claus Busch

Hi Howard,

Am Mon, 14 Oct 2013 15:04:04 -0700 (PDT) schrieb Howard:
Or another way to make it work IS TO PUT IT IN A STANDARD MODULE.
Click to expand...

no matter, I am always glad to help.
Fine, that it is working now. Thank you for the feedback.
Good night.


Regards
Claus B.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Loop thru xx No. of sheets until the four strValue combo's are found 6
Replacing the formula text's substring 4
A For Each in Range... with a .Find(what:="TJ", ... in it problem 15
Macro to Combine Data from Multiple Sheets with Cell References 4
Convert list to UPPER, lower & Proper cases. 21
Concat a three column range into one cell Then Next... 2
Modify working code to expand the output. 5
Advice on multiple macros, same code just a different column 9

Top