I wrote a simple translator / parser to process an EDI (830) document using multiple Select Case statements to determine the code to be executed. I’m opening a file in binary mode and splitting the document into individual lines, then each line is split into the various elements where the first element of every line has a unique segment identifier.
My code works perfectly as written. However, Select Case requires checking every Case until a match is found or the Case Else is executed. I’ve sequenced the Case statements in such a manner that the segments that appear most frequently (as in the case of loops), are placed first to minimize the number of "checks before code is actually executed.
Rather than using multiple Select Cases, I would prefer to determine an index for the segment identifier and simply call the appropriate routine using that index. I’ve used jump tables in C and Assembler and anticipated similar functionality may be possible in VBA.
You can do jump tables in VBA by using the Application.Run method to call the appropriate routine by name. The following code demonstrates how it works:
Public Sub JumpTableDemo()
Dim avarIdentifiers() As Variant
avarIdentifiers = Array("Segment1", "Segment2")
Dim varIdentifier As Variant
For Each varIdentifier In avarIdentifiers
Run "Do_" & varIdentifier
Next varIdentifier
End Sub
Public Sub Do_Segment1()
Debug.Print "Segment1"
End Sub
Public Sub Do_Segment2()
Debug.Print "Segment2"
End Sub
You can do this in Excel VBA, following the example below:
The example assumes you have split your EDI document into two columns, one with the 'processing instruction' and one with the data that instruction will process.
The jump table is to the right i.e. a distinct list of the 'processing instructions' plus a name of a Sub-routine to run for each instruction.
The code is:
Option Explicit
Sub JumpTable()
Dim wsf As WorksheetFunction
Dim ws As Worksheet
Dim rngData As Range '<-- data from your file
Dim rngCell As Range '<-- current "instruction"
Dim rngJump As Range '<-- table of values and sub to run for value
Dim strJumpSub As String
Dim strJumpData As String
Set wsf = Application.WorksheetFunction '<-- just a coding shortcut
Set ws = ThisWorkbook.Worksheets("Sheet1") '<-- change to your worksheet
Set rngData = ws.Range("A2:A17") '<-- change to your range
Set rngJump = ws.Range("E2:F4") '<-- change to your circumstances
For Each rngCell In rngData
strJumpSub = wsf.VLookup(rngCell.Value, rngJump, 2, False) '<-- lookup the sub
strJumpData = rngCell.Offset(0, 1).Value '<-- get the data
Application.Run strJumpSub, strJumpData '<-- call the sub with the data
Next rngCell
End Sub
Sub do_foo(strData As String)
Debug.Print strData
End Sub
Sub do_bar(strData As String)
Debug.Print strData
End Sub
Sub do_baz(strData As String)
Debug.Print strData
End Sub
Make sure that you have written a Sub for each entry in the jump table.
Related
Hello Recently someone posted this in a comment thread in one of my previous questions. The post itself shows a code to remove merged cells and replace them with Central Across Selection
https://codereview.stackexchange.com/questions/197726/getting-rid-of-merged-cells/197730#197730
My issue is that I can't seem to get the code to work. I tried giving the code a go but am having two issues with it. Primarily the:
Sub fixMergedCells(sh As Worksheet)
and later
Set used = sh.UsedRange
Which I don't quite understand and they seem to be stopping me from applying it as a macro button. I otherwise seem to get a debug prompt saying "Method 'UnMerge' of object 'Range' failed" with regards to the line:
.UnMerge
Could you give me a hand in understanding what it is that I can't seem to grasp.
Here is my original code from my other post:
Sub fixMergedCells(sh As Worksheet)
'replace merged cells by Center Acroos Selection
'high perf version using a hack: https://stackoverflow.com/a/9452164/78522
Dim c As Range, used As Range
Dim m As Range, i As Long
Dim constFla: constFla = Array(xlConstants, xlFormulas)
Set used = sh.UsedRange
For i = 0 To 1 '1 run for constants, 1 for formulas
Err.Clear
On Error Resume Next
Set m = Intersect(used.Cells.SpecialCells(constFla(i)), used.Cells.SpecialCells(xlBlanks))
On Error GoTo 0
If Not m Is Nothing Then
For Each c In m.Cells
If c.MergeCells Then
With c.MergeArea
'Debug.Print .Address
.UnMerge
.HorizontalAlignment = xlCenterAcrossSelection
End With
End If
Next c
End If
Next i
End Sub
Sub test_fixMergedCells()
fixMergedCells ActiveSheet
End Sub
Your sub procedure isn't listed in the available 'macros' because it has a non-optional, non-variant parameter.
Try using an optional variant type parameter that can be used or, if omitted, filled with the ActiveSheet (which I assume the button is on).
Sub fixMergedCells(Optional sh As Variant)
If IsMissing(sh) Then Set sh = ActiveSheet
sh.Cells.UnMerge
End Sub
IsMissing can only be used with optional variant type parameters. Sub procedures with optional parameters are only listed as available 'macros' to be assigned to a button if the optional parameter is the variant type.
Is there a vba command to get directly a list without duplicates from the header autofilter of a list object.
My input is this list and I search a way to get this list without duplicates from my object ListObject in vba
Thanks in advance.
you could use this helper function:
Function GetUniqueValues(rng As Range) As Variant
Dim cell As Range
With CreateObject("Scripting.Dictionary")
For Each cell In rng
.Item(cell.Value) = 1
Next
GetUniqueValues = .keys
End With
End Function
to be called by your "main" module as follows:
Option Explicit
Sub main()
Dim uniqueValues As Variant
uniqueValues = GetUniqueValues(ActiveSheet.ListObjects(1).ListColumns(1).DataBodyRange)
'... rest of your code
End Sub
just change ActiveSheet, ListObjects(1) and ListColumns(1) references as per your needs
trying to call this subroutine using a string. I have tried Application.Run like I have read online but that doesn't seem to be working.
The variable element will loop through and represents different state codes. So I have subs called "CA_Config", "GA_Config" "AZ_Config" etc.
Dim strSubToCall As String
strSubToCall = element & "_Config()"
Application.Run strSubToCall
State subs are very different therefore need to be different subroutines. The other subs and the main sub calling the other ones are all public.
Example for CA sub below
Public Sub CA_Config()
Dim rngLastHeader As Range
Dim intLastRow As Integer
Dim i As Integer
intLastRow = Sheet1.currWS.UsedRange.Rows.Count
Set rngLastHeader = Sheet1.currWS.Range("A1").End(xlToRight)
rngLastHeader.Offset(, 1).Value = "Use Tax Reversal Needed"
Sheet1.currWS.Range("X:X").EntireColumn.Copy
Sheet1.currWS.Range("Y:Y").PasteSpecial xlPasteFormats
Sheet1.currWS.Range("Y:Y").Columns.AutoFit
End Sub
Remove parenthesis and prepend your Sub name with module name. For instance, Application.Run "Module1.MySub".
I dimmed the variable:
Dim mainTableRange As Range
Then gave it a value:
Set mainTableRange = Range("tLedgerData") ' tLedgerData is an Excel table.
Now I'm trying to get the name of the table (which is "tLedgerData") from the variable to reference columns in that table even if the table name changes.
I tried
mainTableRange.Name
and
mainTableRange.Name.Name
(See how do you get a range to return its name.) Both threw run-time error '1004': Application defined or object-defined error.
mainTableRange.Select selected all table data excluding the header and total rows.
I think you're having an X-Y problem here: solving problem X when the solution is for problem Y.
[...] to reference columns in that table even if the table name changes
Have the table / ListObject alone on its own dedicated worksheet, and give the sheet a CodeName. That way you can do this:
Dim tbl As ListObject
Set tbl = LedgerDataSheet.ListObjects(1)
And now you have the almighty power of the ListObject API to do whatever it is that you want to do. For example, retrieve the column names:
Dim i As Long
For i = 1 To tbl.ListColumns.Count
Debug.Print tbl.ListColumns(i).Name
Next
In other words, you don't need to care for the name of the table. What you want is to work with its ListObject. And since you never need to refer to it by name, the table's name is utterly irrelevant and the user can change it on a whim, your code won't even notice.
I believe an Excel table and named-range are two different things which is why the .name.name doesn't work. A table is a ListObject and once you set a range equal to a table you should be able to continue to call that range without an error.
Curious, what is the reason why your table might change unexpectedly?
I wrote out some lines of code to show a couple things. You can create tables and reuse the range variables after the table name changes. You can also set AlternativeText for the table with some identifying string and use that to locate a particular table if you suspect the table name may change.
Option Explicit
Public TestTable As Range
Sub CreateTable()
ActiveSheet.ListObjects.Add(xlSrcRange, [$A$1:$C$4], , xlYes).name = "Table1"
ActiveSheet.ListObjects("Table1").AlternativeText = "Table1"
End Sub
Sub SetTableRange()
Set TestTable = Range("Table1")
End Sub
Sub SelectTable()
TestTable.Select
End Sub
Sub RenameTable()
ActiveSheet.ListObjects("Table1").name = "Table2"
[A1].Select
End Sub
Sub SelectRenamedTable()
TestTable.Select
End Sub
Sub ClearSelection()
[A1].Select
End Sub
Sub FindTable1()
Dim obje As ListObject
For Each obje In ActiveSheet.ListObjects
If obje.AlternativeText = "Table1" Then
MsgBox "Found " & obje.AlternativeText & ". Its current name is: " & obje.name
End If
Next obje
End Sub
Sub ConvertTablesToRanges()
' I found this snippet in a forum post on mrexcel.com by pgc01 and modified
Dim rList As Range
On Error Resume Next
With ActiveSheet.ListObjects("Table1")
Set rList = .Range
.Unlist ' convert the table back to a range
End With
With ActiveSheet.ListObjects("Table2")
Set rList = .Range
.Unlist ' convert the table back to a range
End With
On Error GoTo 0
With rList
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlColorIndexAutomatic
.Borders.LineStyle = xlLineStyleNone
End With
End Sub
I'm trying to establish the logic for creating a navigation menu for a budget tracking system: it has 12 sheets for each budget line with 12 monthly tables per sheet.
The navigation menu is based on two combo boxes, one listing the sheets, and the other the names of the months - when a user selects where to go, the sheet and first cell in the chosen table activate.
What I'm looking for is a more effective way to organize this than writing 144 distinct if-then conditions accounting for every possible listindex combination the user might choose. The Select Case approach also works, but it is equally voluminous in scope...
I have been investigating using loops for the purpose - e.g. ListIndex values can be defined in a loop, but I'm coming up short on ideas for the overarching concept.
Thank you in advance!
Here I set up a workbook with 12 worksheets one for each month. Each worksheet has 12 tables on it. When the user selects a worksheet from the dropdown (cboWorkSheets) the second drop down (cboTables) list is cleared and then all the table names from the selected worksheet is added to back to the list.
When a user selects a table name from cboTables the worksheet referenced by cboWorkSheets is searched for that table. The first cell in the table's databody range is then selected.
Option Explicit
Private Sub cboTables_Change()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = Worksheets(cboWorkSheets.Value)
Set tbl = ws.ListObjects(cboTables.Value)
ws.Activate
tbl.DataBodyRange.Cells(1, 1).Select
End Sub
Private Sub cboWorkSheets_Change()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = Worksheets(cboWorkSheets.Value)
cboTables.Clear
For Each tbl In ws.ListObjects
cboTables.AddItem tbl.Name
Next
End Sub
Private Sub UserForm_Initialize()
cboWorkSheets.List = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9", "Sheet10", "Sheet11", "Sheet12")
End Sub
Doing the sheet selection is pretty straightforward. Just create an array that will hold the sheet name that corresponds to the ListIndex. Something like this
Dim myArray(11) As String
myArray(0) = "a"
myArray(1) = "b"
myArray(2) = "c"
...
myArray(10) = "k"
myArray(11) = "l"
Worksheets(myArray(ComboBox1.ListIndex)).Activate
If the person selects the 5th ComboBox element, sheet "e" would be activated.
Selecting the table cell is a bit more problematic since it depends on where on the sheet the tables are located. If they are spaced equidistantly apart, you can use a simple math formula. That is, if the January table starts at E7, Feb at E27, Mar at e47, then it is a simple matter of using the listindex to calculate the starting row. Eg:
Worksheets(myArray(ComboBox1.ListIndex)).Cells(7 + ComboBox2.ListIndex * 20, "E").Select
Hope this helps. :)
As general interest, this is the functional version of the code for a proof of concept file I built around #Tim's example, given above. Here goes:
In Module1:
Sub ComboBox1_Change()
Dim sheets_array(0 To 2) As Variant
sheets_array(0) = "Sheet1"
sheets_array(1) = "Sheet2"
sheets_array(2) = "Sheet3"
With UserForm1.ComboBox1
.Clear
.List = sheets_array
.Style = fmStyleDropDownCombo
End With
Call ComboBox2_Change
UserForm1.Show
End Sub
Sub ComboBox2_Change()
Dim monthsarray(0 To 3) As Variant
monthsarray(0) = "April"
monthsarray(1) = "May"
monthsarray(2) = "June"
With UserForm1.ComboBox2
.Clear
.List = monthsarray
.Style = fmStyleDropDownCombo
End With
End Sub
In the UserForm1 code window:
Private Sub ComboBox1_Change()
With UserForm1.ComboBox1
Worksheets(.List(.ListIndex)).Activate
End With
End Sub
Private Sub ComboBox2_Change()
With Worksheets(UserForm1.ComboBox1.ListIndex)
.Select
.Cells(7 + UserForm1.ComboBox2.ListIndex * 20, "E").Select
End With
End Sub
#Thomas Inzina, your solution is considerably more elegant and I hope I can think about programming at your level at some point.