?
Solved

Modifying functions to handle 3 different scenarios at once

Posted on 2011-09-26
7
Medium Priority
?
291 Views
Last Modified: 2012-05-12
Please take a look at the attached workbook and let me know if there is a way to accomodate situations in which all three of the scenarios, described in the two functions below, appear in one cell.

Thanks,
John
Function GetSeatsABC(InputCell As Range) As String
    Dim RegEx, RegM, RegMC
    Dim MyDic
    Dim tmpStr As String
    Dim i As Long
    Set MyDic = CreateObject("scripting.dictionary")
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .Pattern = "(?:ROW|seat)(S)?\s*(\d+)\s*\w*\s*([,-/|]|to| |thru|through)\s*\w{0,5}?\s*(\d+)"
        .Global = True
        .IgnoreCase = True
        If .test(InputCell.Value) Then
            Set RegMC = .Execute(InputCell)
            For Each RegM In RegMC
                If MyDic.exists(LCase$(RegM)) = False Then

                    For i = RegM.submatches(1) To RegM.submatches(3)
                            tmpStr = tmpStr & i & cells(InputCell.Row, [SeatColumnCounts].Column) & " | "
                    Next
                    tmpStr = Left$(tmpStr, Len(tmpStr) - 2)
                    MyDic.Add LCase$(RegM), 1
                End If
            Next
        End If
        .Pattern = "\d{1,3}[ /-]?(?!jan|feb|apr|ma[ry]|ju[ln]|aug|sep|oct|nov|dec|in|by|mi|hrs|AVOD|check|GMT|jump|and|dtd|fail|area|headset)[A-M]+"           'TerryAtOpus
        If .test(InputCell.Value) Then
            Set RegMC = .Execute(InputCell)
            For Each RegM In RegMC
                If tmpStr = vbNullString Then
                    tmpStr = RegM
                Else
                    tmpStr = tmpStr & " | " & RegM
                End If
            Next
        End If
GetSeatsABC = tmpStr
    End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSeats(InputCell As Range) As String
    Dim RegEx, RegM, RegMC
    Dim MyDic
    Dim tmpStr As String
    Dim i As Long
    Set MyDic = CreateObject("scripting.dictionary")
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
.Pattern = "(?:ROW|SEAT)(S)?\s*(\d+)\s*([,-/|]|to|thru|through|til|till)\s*(\d+)"
.Global = True
.IgnoreCase = True
        If .test(InputCell.Value) Then
            Set RegMC = .Execute(InputCell)
            For Each RegM In RegMC
                If MyDic.exists(LCase$(RegM)) = False Then
                    For i = RegM.submatches(1) To RegM.submatches(3)
                        Select Case i
                        Case Is <= cells(InputCell.Row, [J_Hi].Column)
                            tmpStr = tmpStr & i & cells(InputCell.Row, [SeatsAcrossJ].Column) & " | "
                        Case Is <= cells(InputCell.Row, [B_Hi].Column)
                            tmpStr = tmpStr & i & cells(InputCell.Row, [SeatsAcrossB].Column) & " | "
                        Case Is <= cells(InputCell.Row, [Y_Hi].Column)
                        tmpStr = tmpStr & i & cells(InputCell.Row, [SeatsAcrossY].Column) & " | "
                        Case Else
                            tmpStr = tmpStr & i & cells(InputCell.Row, [SeatsAcrossY2].Column) & " | "
                        End Select
                    Next
                    
                MyDic.Add LCase$(RegM), 1
                End If
            Next
            tmpStr = Left$(tmpStr, Len(tmpStr) - 2)
        End If
.Pattern = "\d{1,3}[ /-]?(?!jan|feb|apr|ma[ry]|ju[ln]|aug|sep|oct|nov|dec|in|by|mi|hrs|AVOD|check|GMT|jump|and|dtd|fail|area|headset)[A-M]+"  
        If .test(InputCell.Value) Then
            Set RegMC = .Execute(InputCell)
            For Each RegM In RegMC
                If tmpStr = vbNullString Then
                    tmpStr = RegM
                Else
                    tmpStr = tmpStr & " | " & RegM
                End If
            Next
        End If
GetSeats = tmpStr
    End With
End Function

Open in new window

GetSeats.xlsm
0
Comment
Question by:gabrielPennyback
[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
  • 4
  • 2
7 Comments
 
LVL 17

Expert Comment

by:andrewssd3
ID: 36710540
Could you please give some more detail about the three scenarios and some explanation of how you arrive at the values you're expecting to see in AD7 and AD11?  I suspect the reason this hasn't been answered yet is that you're asking quite a lot for people to dive in and fully understand what's happening without any background information.
0
 
LVL 1

Author Comment

by:gabrielPennyback
ID: 36719728
Hi andrewssd3, thanks for posting. Please let me know if the revised workbook gives you enough to go on.

Thanks,
John
GetSeats-v2.xlsm
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 36720067
Thanks for clarifying.  I'll take a look at this as soon as I can.  But it's nearly my bedtime now...
0
Independent Software Vendors: 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!

 
LVL 17

Accepted Solution

by:
andrewssd3 earned 2000 total points
ID: 36816034
Hi John - I've had a first shot at this, and written a new function that does everything in one go - GetSeatsNew.  I've basically used the regex patterns you had with small amendments, so I haven't reinvented the complex one that identifies individual seats, except to add a couple of submatches.  I've tried to put in some comments to make it easier to change next time.

The change to the formula is that it requires the ranges of row allocation per class (CC:CL) and seats per row (CU:CY). I did this so that Excel will recalculate the formula whenever there are changes either to the incident strings or to the seat allocation - previously you would have had to reenter the formulas if there was a change to seat allocation.

I have stripped out all your other code from this sample, but you can drag the new calcSeats module into your version if you like it. I think the button to calc the seat clusters is now redundant, as column BT isn't now used.

Let me know what you think.  I've put the main function code inline here, but there are a couple of extra help functions in the file I've attached.
Cheers
Stuart

Function GetSeatsNew(ByRef InputCell As Excel.Range, _
                        ByRef rowAssignments As Excel.Range, _
                        ByRef rowSeats As Excel.Range _
                        ) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSeatsNew
' DateTime  : 29/09/2011 14:45
' Author    : andrewssd3 - EE
' Desc      : inputCell is the incident string from which we will extract the seat info
'             rowAssigments is the range indicating what row belongs in what class
'                           - there will be 2 cols (start and end range) per class
'             rowSeats specifies the seats available in each class - must have half
'                           as many columns as rowAssignments
'---------------------------------------------------------------------------------------
'
    Dim RegEx As Object, RegM As Object, RegMC As Object
    Dim MyDic As Object
    Dim tmpStr As String
    Dim i As Integer
    Dim intRowFirst As Integer, intRowLast As Integer
    
    Dim intMaxRows As Integer
    Dim aRows() As String
    
    Dim strPartialRow As String
    Dim strRowSeats As String
    Dim strSearch As String
    
    Const cstrPattSeatRange As String = _
"(?:ROW|seat)(?:S)?\s*(\d+)\s*([A-M]*)\s*([,-/|]|to| |thru|through)\s*\w{0,5}?\s*(\d+)\s*([A-M]*)"
'Submatches-----------( 0 )---( 1    )---(            2           )--------------( 3 )---( 4    )
' (0) - first row
' (1) - row seats (optional, but should not be present with (4))
' (2) - range indicator (not used currently)
' (3) - last row
' (4) - row seats (optional, but should not be present with (1))

    Set MyDic = CreateObject("scripting.dictionary")
    Set RegEx = CreateObject("vbscript.regexp")
    
    intMaxRows = Application.WorksheetFunction.max(rowAssignments)
    ReDim aRows(1 To intMaxRows)
    
    strSearch = InputCell.Value
    
    With RegEx
        .Pattern = cstrPattSeatRange
        .Global = True
        .IgnoreCase = True
        If .test(strSearch) Then
            Set RegMC = .Execute(InputCell)
            For Each RegM In RegMC
                intRowFirst = RegM.submatches(0)
                intRowLast = RegM.submatches(3)
                ' partial seat info for the row should be either after the firs row,
                ' or after the last - so if both a present, use the first and ignore the last
                strPartialRow = _
                    IIf(Len(RegM.submatches(1)) > 0, RegM.submatches(1), RegM.submatches(4))
                ' if no partial row info was found, get all seats for these rows
                
                ' for each row, get the row seats for this row if it is a full row, then
                ' merge the seats with any already found for this row
                For i = intRowFirst To intRowLast
                    If Len(strPartialRow) = 0 Then
                        strRowSeats = GetSeatsForRow(i, rowAssignments, rowSeats)
                    Else
                        strRowSeats = strPartialRow
                    End If
                    If strRowSeats <> aRows(i) Then     ' if not already added all these seats
                        aRows(i) = MergeSeats(aRows(i), strRowSeats)
                    End If
                Next i
                ' blank out this find to prevent it from confusing the search for inividual seats
                Mid$(strSearch, RegM.firstindex + 1, RegM.Length) = String(RegM.Length, "~")
            Next RegM
        End If
        
        ' search for individual seats
        .Pattern = "(\d{1,3})[ /-]?(?!jan|feb|apr|ma[ry]|ju[ln]|aug|sep|oct|nov|dec|in|by|mi|hrs|AVOD|check|GMT|jump|and|dtd|fail|area|headset)([A-M]+)"           'TerryAtOpus
        If .test(strSearch) Then
            Set RegMC = .Execute(InputCell)
            For Each RegM In RegMC
                i = RegM.submatches(0)
                strRowSeats = RegM.submatches(1)
                If strRowSeats <> aRows(i) Then     ' if not already added all these seats
                    aRows(i) = MergeSeats(aRows(i), strRowSeats)
                End If
            Next
        End If
    End With
    
    ' build the return string by looping through the rows array and outputting
    ' all rows that have been touched
    tmpStr = vbNullString
    For i = 1 To UBound(aRows)
        If Len(aRows(i)) > 0 Then
            If Len(tmpStr) > 0 Then
                tmpStr = tmpStr & " | " & CStr(i) & aRows(i)
            Else
                tmpStr = CStr(i) & aRows(i)
            End If
        End If
    Next i
    
    GetSeatsNew = tmpStr
End Function

Open in new window

GetSeats-v2.xlsm
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 36954584
John - I put in quite bit of work on this for you a couple of weeks ago, and I think it was a pretty good solution - have you had a chance to test it yet (and maybe allocate some points :))

Stuart
0
 
LVL 1

Author Closing Comment

by:gabrielPennyback
ID: 37097015
Hi Stuart, I've been on vacation since October 28 and in the usual pre-vacation madness I forgot to close this question, please accept my apologies. And thank you for your answer!

alias99, thanks for clarifying the Ask a Related Question procedure, I'll definitely do this in the future.

- John
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

765 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