VBA Query

[matt1107]

Hi All,

I have a large data set in sheet1 which has ~20 columns and 10000+rows and each row has a set of limits based on what value is in column B this data set changes ~once per week.

The limits are stored in sheet2 where column A contains the unique list of values from column B in sheet1 and the min and max limits are stored over ~40 rows to the right of the value.

Easiest way I can think to explain is below example I have searched a lot and can't come up with the answer but I am currently doing this with index match then a formula to check if it is within the limits but it takes an age to load so i wish to do this with vba so i can update it as and when and if I need to leave it to run for a bit I can; but the sheet would then be usable and quick afterwards.

example sheet 1:

header 1	header 2	header 3	header 4
random value1	A	1	2
random value2	B	4	2
random value3	A	6	3

<tbody>
</tbody>

example sheet 2:

sheet 1 header 2 value	min limit for header 3 sheet 1	max limit for header 3 sheet 1	min limit for header 4 sheet 1	max limit for header 4 sheet 1
A	3	9	1	4
B	3	7	5	8

<tbody>
</tbody>

result:

header 1	header 2	header 3	header 4	min limit for header 3 sheet 1	max limit for header 3 sheet 1	min limit for header 4 sheet 1	max limit for header 4 sheet 1	within limits header 3	within limits header 4	within limits overall
random value1	A	1	2	3	9	1	4	no	yes	fail
random value2	B	4	2	3	7	5	8	yes	no	fail
random value3	A	6	3	3	9	1	4	yes	yes	pass

<tbody>
</tbody>

I hope this makes sense as this problem is driving me crazy as it takes me a long time to do anything with the data as I have to review the data on an almost daily basis.

Thanks in advance to any help I can get as I am fairly new to vba but I'm sure this is where the answer lies.

Regards,
Matt

 

[matt1107]

OK so progress update I have done a bit more digging and used some different phrases for searches and have found this thread VBA Macro To Find Value & Copy Corresponding Cell and got the following code (below) working to find the value (header 2 in original post and go down for the whole column) and copy 1 value (i.e. the very first min limit) and paste in it the correct place!!! YAY!!! However I need to copy a range of ~50 columns and can't figure out how to adjust the code accordingly...any help?

code below

'=========================================================
'- GENERIC LOOKUP MACRO TO
'- FIND A VALUE IN ANOTHER WORKSHEET
'- AND RETURN A VALUE FROM ANOTHER COLUMN
'=========================================================
'- select the cell containing the first search value
'- and run this macro from there.
'- can be set to continue down the column
'- [** need to make changes below as required **]
'- Brian Baulsom May 2005
'==========================================================
Dim MyValue As Variant
Dim FromSheet As Worksheet
Dim LookupColumn As Integer
Dim FromRow As Long
Dim FromColumn As Integer
'-
Dim ToSheet As Worksheet
Dim StartRow As Long
Dim LastRow As Long
Dim ActiveColumn As Integer
Dim ReturnColumnNumber
Dim ToRow As Long
Dim FoundCell As Object

'=============================================================
'- MAIN ROUTINE
'=============================================================
Sub DO_LOOKUP()
Application.Calculation = xlCalculationManual
'----------------------------------------------------------
'- LOOKUP SHEET [**AMEND AS REQUIRED**]
Set FromSheet = Workbooks("Feb 2017 new2 (2).xlsm").Worksheets("Limits")
LookupColumn = 1 ' look for match here
FromColumn = 2 ' return value from here
'-----------------------------------------------------------
'- ACTIVE SHEET
Set ToSheet = ActiveSheet
ActiveColumn = ActiveCell.Column
StartRow = ActiveCell.Row
'-------------------------------------------------------------
'- COMMENT OUT UNWANTED LINE, UNCOMMENT THE OTHER
'- ..............................[** FOR MULTIPLE ROWS **]
LastRow = ToSheet.Cells(65536, ActiveColumn).End(xlUp).Row
'-
'- ..............................[** FOR A SINGLE VALUE **]
'-LastRow = ActiveCell.Row
'-------------------------------------------------------------
'- COLUMN NUMBER TO PUT RETURNED VALUE [**AMEND AS REQUIRED**]
ReturnColumnNumber = 100 ' column number
'-------------------------------------------------------------
'- loop through each row (which may be only 1)
For ToRow = StartRow To LastRow
MyValue = ToSheet.Cells(ToRow, ActiveColumn).Value
FindValue
Next
'-------------------------------------------------------------
'- finish
MsgBox ("Done")
Application.Calculation = xlCalculationAutomatic
End Sub
'== END OF PROCEDURE ====================================================

'========================================================================
'- FIND VALUE
'========================================================================
Private Sub FindValue()
Set FoundCell = _
FromSheet.Columns(LookupColumn).Find(MyValue, LookIn:=xlValues)
If FoundCell Is Nothing Then
'- MsgBox (MyValue & " not found.")
Else
FromRow = FoundCell.Row
'- transfer additional data.
ToSheet.Cells(ToRow, ReturnColumnNumber).Value = _
FromSheet.Cells(FromRow, FromColumn).Value
End If
End Sub
'=========================================================================

 

[matt1107]

Figured it out, took me a bit but i got there....see code attached if anyone is interested.

'=========================================================
'- GENERIC LOOKUP MACRO TO
'- FIND A VALUE IN ANOTHER WORKSHEET
'- AND RETURN A VALUE FROM ANOTHER COLUMN
'=========================================================
'- select the cell containing the first search value
'- and run this macro from there.
'- can be set to continue down the column
'- [** need to make changes below as required **]
'- Brian Baulsom May 2005
'==========================================================
Dim MyValue As Variant
Dim FromSheet As Worksheet
Dim LookupColumn As Integer
Dim FromRow As Long
Dim FromColumn As Integer
'-
Dim ToSheet As Worksheet
Dim StartRow As Long
Dim LastRow As Long
Dim ActiveColumn As Integer
Dim ReturnColumnNumber
Dim ToRow As Long
Dim FoundCell As Object

'=============================================================
'- MAIN ROUTINE
'=============================================================
Sub DO_LOOKUP()
Application.Calculation = xlCalculationManual
'----------------------------------------------------------
'- LOOKUP SHEET [**AMEND AS REQUIRED**]
Set FromSheet = Workbooks("Feb 2017 new2 (2).xlsm").Worksheets("Limits")
LookupColumn = 1 ' look for match here
FromColumn = 2 ' return value from here
'-----------------------------------------------------------
'- ACTIVE SHEET
Set ToSheet = ActiveSheet
ActiveColumn = ActiveCell.Column
StartRow = ActiveCell.Row
'-------------------------------------------------------------
'- COMMENT OUT UNWANTED LINE, UNCOMMENT THE OTHER
'- ..............................[** FOR MULTIPLE ROWS **]
LastRow = ToSheet.Cells(65536, ActiveColumn).End(xlUp).Row
'-
'- ..............................[** FOR A SINGLE VALUE **]
'-LastRow = ActiveCell.Row
'-------------------------------------------------------------
'- COLUMN NUMBER TO PUT RETURNED VALUE [**AMEND AS REQUIRED**]
ReturnColumnNumber = 100 ' column number
'-------------------------------------------------------------
'- loop through each row (which may be only 1)
For ToRow = StartRow To LastRow
MyValue = ToSheet.Cells(ToRow, ActiveColumn).Value
FindValue
Next
'-------------------------------------------------------------
'- finish
MsgBox ("Done")
Application.Calculation = xlCalculationAutomatic
End Sub
'== END OF PROCEDURE ====================================================

'========================================================================
'- FIND VALUE
'========================================================================
Private Sub FindValue()
Set FoundCell = _
FromSheet.Columns(LookupColumn).Find(MyValue, LookIn:=xlValues)
If FoundCell Is Nothing Then
'- MsgBox (MyValue & " not found.")
Else
FromRow = FoundCell.Row

'- transfer additional data RANGE. option 1(385 rows & 41 columns copied 17 seconds)


FromSheet.Select
Range(Cells(FromRow, FromColumn), Cells(FromRow, 41)).Select
Selection.Copy
ToSheet.Select
Cells(ToRow, ReturnColumnNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'- transfer additional data RANGE. option 2 (385 rows & 41 columns copied 49 seconds)

'- inumberofloops = 40
'- For i = 0 To inumberofloops
'- ToSheet.Cells(ToRow, ReturnColumnNumber).Offset(, i).Value = _
'- FromSheet.Cells(FromRow, FromColumn).Offset(, i).Value
'- Next i


'- transfer additional data SINGLE cell.

'- ToSheet.Cells(ToRow, ReturnColumnNumber).Value = _
'- FromSheet.Cells(FromRow, FromColumn).Value
End If
End Sub
'=========================================================================