ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.
One of a set of tools we're offering as a way to say thank you for being a part of the community.
Multiple criteria index / match in VBA
In the attached file, which generates a chart based on data in two different tables, I used a logic where upon cell change in tab Retrieve, cell C1, I pull data from tabs Tank Data and Measurements.
I have two questions on the below code (all the code is located on the Retrieve worksheet module), marked by 'EE Question comments. I have a block of code where I loop in a range to put arrayformulas individually. I think there must be a better way. I have another block of code where I put array formulas in the worksheet to locate a record. There has to be a better way to do that.
My code works, does what it's supposed to do, but I'd like some input on how it could be done better, faster, neater.
Thanks for your teachings,
Thomas
I have two questions on the below code (all the code is located on the Retrieve worksheet module), marked by 'EE Question comments. I have a block of code where I loop in a range to put arrayformulas individually. I think there must be a better way. I have another block of code where I put array formulas in the worksheet to locate a record. There has to be a better way to do that.
My code works, does what it's supposed to do, but I'd like some input on how it could be done better, faster, neater.
Thanks for your teachings,
Thomas
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range, strComment As String, strFormat As String
Dim lgCol As Long, lgRow As Long, bolTop As Boolean
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
on Error GoTo endSub 'manage errors to avoid keeping the app in a events and screenupdating disabled state
If Not Intersect(Target, Range("clBlend")) Is Nothing Then 'if blend selection has changed
ActiveSheet.Unprotect
With Range("rgTemps") 'update temperatures (put formula in range then copy values and clean up)
'sumproduct will only work if there are no data duplicates, otherwise, it would double the value
.FormulaR1C1 = _
"=SUMproduct(tblmeasures_Temp,(tblmeasures_Tank=clTank)*(tblmeasures_Date=RC15)*(tblmeasures_Time=RC16))"
.Value = .Value
For Each cl In .Cells 'this part needed to convert cells to blank cells, so they don't get picked by the chart
If cl = 0 Then cl.ClearContents
Next
End With
With Range("rgBeaume") 'update Beaume (put formula then copy value)
'sumproduct will only work if there are no data duplicates, otherwise, it would double the value
.FormulaR1C1 = _
"=SUMproduct(tblmeasures_Beaume,(tblmeasures_Tank=clTank)*(tblmeasures_Date=RC15)*(tblmeasures_Time=RC16))"
.Value = .Value
For Each cl In .Cells 'this part needed to convert cells to blank cells, so they don't get picked by the chart
If cl = 0 Then cl.ClearContents
Next
End With
'EE QUESTION: IS THERE A BETTER WAY THAN TO CREATE A LOOP HERE
For Each cl In Range("rgComments").Cells 'retrieve comments
With cl
'locate the comment for the right tank, day, time
.FormulaArray = _
"=INDEX(offset(tblMeasures_Tank,0,match(" & Cells(Range("rgComments").Row - 1, cl.Column).Address & ",offset(tblMeasures_xl03,0,0,1),0)-1)," & _
"MATCH(O" & cl.Row & " ,IF(tblmeasures_Time=P" & cl.Row & _
",IF(tblmeasures_Tank=clTank,tblmeasures_Date)),0))"
.Value = .Value
'If no comment is found delete errors and zeroes
If IsError(.Value) Then
.ClearContents
ElseIf .Value = 0 Then
.ClearContents
End If
End With
Next
'rgTopUpdate is the range of cells updated from [Tank Data] where the title is one row above the cell
For Each cl In Range("rgTopUpdate").Cells 'retrieve tank details
With cl
strFormat = .NumberFormat
.NumberFormat = "General"
'locate the value for blend and column
.FormulaArray = _
"=INDEX(offset(tbltank_tank,0,match(""" & cl.Offset(-1) & """,offset(tbltank_xl03,0,0,1),0)-1)," & _
"MATCH(""" & Range("clBlend") & """ ,tbltank_BlendID,0))"
.Value = .Value
'If no comment is found delete errors and zeroes
If IsError(.Value) Then
.ClearContents
ElseIf .Value = 0 Then
.ClearContents
End If
.NumberFormat = strFormat
End With
Next
'rgLeftUpdate is the range of cells updated from [Tank Data] where the title is one column left of the cell
For Each cl In Range("rgLeftUpdate").Cells 'retrieve tank details
With cl
strFormat = .NumberFormat
.NumberFormat = "General"
.FormulaArray = _
"=INDEX(offset(tbltank_tank,0,match(""" & cl.Offset(0, -1) & """,offset(tbltank_xl03,0,0,1),0)-1)," & _
"MATCH(""" & Range("clBlend") & """ ,tbltank_BlendID,0))"
.Value = .Value
'If no comment is found delete errors and zeroes
If IsError(.Value) Then
.ClearContents
ElseIf .Value = 0 Then
.ClearContents
End If
.NumberFormat = strFormat
End With
Next
ActiveSheet.Protect
GoTo endSub:
End If
If Not Intersect(Target, Range("rgComments")) Is Nothing Then
'if a value gets updated, locate the record and update the Measurements table
With Intersect(Target, Range("rgComments"))
strComment = .Value 'store new comment
'EE QUESTION: WHAT IS A BETTER WAY THAN GETTING THE ROW AND COLUMN THROUGH WORKSHEET FORMULAS
'find column number where comment should go
.Formula = "=match(" & Cells(Range("rgComments").Row - 1, .Column).Address & ",offset(tblMeasures_xl03,0,0,1),0)"
lgCol = .Value
'find row number where comment should go
.FormulaArray = "=MATCH(O" & Target.Row & " ,IF(tblmeasures_Time=P" & Target.Row & _
",IF(tblmeasures_Tank=clTank,tblmeasures_Date)),0)"
If IsError(.Value) Then 'if that line doesn't exist
MsgBox "Comments only allowed on measurement days. " & vbCrLf & _
"This comment will be deleted on update." & vbCrLf & _
"Enter your measurements on the Measurements tab"
.Value = strComment
Else 'if it exists, add or update the comment to the line
shtMeasure.Range("tblMeasures_xl03").Cells(.Value + 1, lgCol) = strComment
.Value = strComment
End If
End With
End If
If Not Intersect(Target, Range("rgLeftUpdate")) Is Nothing _
Or Not Intersect(Target, Range("rgTopUpdate")) Is Nothing Then
If Not Intersect(Target, Range("rgLeftUpdate")) Is Nothing Then
Set cl = Intersect(Target, Range("rgLeftUpdate"))
bolTop = False
Else
Set cl = Intersect(Target, Range("rgTopUpdate"))
bolTop = True
End If
With cl
strComment = .Value 'store new comment
'find column number where comment should go
strFormat = .NumberFormat
.NumberFormat = "General"
.Formula = "=match(""" & cl.Offset(IIf(bolTop, -1, 0), IIf(bolTop, 0, -1)) & """,offset(tbltank_xl03,0,0,1),0)"
lgCol = .Value
'find row number where comment should go
.Formula = "=MATCH(""" & Range("clBlend") & """ ,tbltank_BlendID,0)"
lgRow = .Value
.NumberFormat = strFormat
.Value = strComment
shtTank.Range("tblTank_xl03").Cells(lgRow + 1, lgCol) = strComment
End With
End If
endSub:
If Err <> 0 Then MsgBox "An error occurred. Please contact your nearest Excel support"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Asked:
3 Solutions
Instead of:
you can use:
for example.
.Formula = "=match(" & Cells(Range("rgComments").Row - 1, .Column).Address & ",offset(tblMeasures_xl03,0,0,1),0)"
lgCol = .Value
you can use:
lgCol = Application.match(Cells(Range("rgComments").Row - 1, .Column).Value, range("tblMeasures_xl03").Rows(1), 0)
for example.
The value assignments are an exciting improvement over copy/paste - a recent (last 12 month) learning for me. And you don't have to do them one cell at a time...
The code suggested:
'you can loop through rows with.
For i = 1 To 10
Worksheets("Retrieve").Cel
Next i
can be simplified to (in the spirit of "neater,faster,etc.") one statement:
of course, if you assign these ranges ahead of the value assignment, that one statement would even look alot simpler.
Enjoy!
Dave
The code suggested:
'you can loop through rows with.
For i = 1 To 10
Worksheets("Retrieve").Cel
Next i
can be simplified to (in the spirit of "neater,faster,etc.") one statement:
Range(Worksheets("Retrieve").Cells(1, 2), Worksheets("Retrieve").Cells(10, 2)).Value = Range(Worksheets("Measurements").Cells(1, 2), Worksheets("Measurements").Cells(10, 2))
of course, if you assign these ranges ahead of the value assignment, that one statement would even look alot simpler.
Enjoy!
Dave
Question has a verified solution.
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
Join & Write a Comment Already a member? Login.
Featured Post
Tackle projects and never again get stuck behind a technical roadblock.
Join Now
I would move away from inserting formulas and go straight to a VBA approach. It gets messy when you combine VBA and formulas.
it looks like you are copying data from one table to another. let me know the specifics and I will help you get started.
to start you off, the basic syntax is
Worksheets("Retrieve").Cel
'where 1, 2 is row, column
'you can loop through rows with.
For i = 1 To 10
Worksheets("Retrieve").Cel
Next i