Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Multiple criteria index / match in VBA

Posted on 2011-02-17
5
3 solutions
Medium Priority
?
2,064 Views
Last Modified: 2012-05-11
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




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

Open in new window

2010-white-ferment-sheet.xls
0
Comment
Question by:nutsch
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Join The Community
5 Comments
 
LVL 11

Accepted Solution

by:
thydzik earned 672 total points
ID: 34923731
I have had a look at your code and understand the basics of what you are trying to achieve.

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").Cells(1, 2).Value = Worksheets("Measurements").Cells(1, 2).Value
'where 1, 2 is row, column

'you can loop through rows with.
For i = 1 To 10
    Worksheets("Retrieve").Cells(i, 2).Value = Worksheets("Measurements").Cells(i, 2).Value
Next i
0
 
LVL 85

Assisted Solution

by:Rory Archibald
Rory Archibald earned 664 total points
ID: 34924517
Instead of:
.Formula = "=match(" & Cells(Range("rgComments").Row - 1, .Column).Address & ",offset(tblMeasures_xl03,0,0,1),0)"
        lgCol = .Value

Open in new window


you can use:
lgCol = Application.match(Cells(Range("rgComments").Row - 1, .Column).Value, range("tblMeasures_xl03").Rows(1), 0)

Open in new window


for example.
0
 
LVL 42

Assisted Solution

by:dlmille
dlmille earned 664 total points
ID: 34990958
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").Cells(i, 2).Value = Worksheets("Measurements").Cells(i, 2).Value
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))

Open in new window


of course, if you assign these ranges ahead of the value assignment, that one statement would even look alot simpler.

Enjoy!

Dave
0
 
LVL 24

Expert Comment

by:Tracy
ID: 35225331
This question has been classified as abandoned and is being closed as part of the Cleanup Program. See my comment at the end of the question for more details.
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Take Survey Now!
Question has a verified solution.

If you are experiencing a similar issue, please ask a related question
Connect to SAP R/3 and call custom FM from MS Excel
Article by: ExcelGuide
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
MS Excel - using the Hyperlink formula
Article by: Thomas
Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
Find Your Competitors' Best Backlinks Using Excel Pivot Tables
Video by: AnnieCushing
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
How to use the IF function in Excel
Video by: Bob
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…
Advertise Here

688 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Advertise Here