Edit 10/20/2020: Just noticed that this code will not work for any rolls that start with 2 digits (such as 12d6). I will work on a fix for that. Currently it won't throw a code or anything, it just ignores them. I am honestly not sure if something like this already exists because I mainly did it to practice VBA and excel macros, but since I'm fairly pleased with how it turned out I figured I would share it for anyone that mind find some use for it. The Macro Basically the code below can be copied and pasted into a brand new excel worksheet VBA module and work after running the first sub routine from the VBE. After that, everything works within Sheet 1. Simply enter a table name, copy a table from the Roll 20 website, press ctrl+v inside the worksheet, then press the submit button. It will convert the table date into the syntax required for entering tables into your game using the Table Export and Recursive Table scripts. Simply Copy the D column and paste into chat! You can also create a new sheet and copy paste multiple outputs into one column and submit them all at once. Also, it works for any table and if you want a table with the dice rolls as text instead of used for Recursive Tables there is a section in the macro that can be commented out. I have only just started using VBA these past two weeks so some of the code may not be optimal or clean but as far as I can tell it works as I expected it too. Example Screenshot Things to note This is meant to run on a brand new instance of excel, it may error with the shape creation if other shapes existed already, or if the beginning subroutine is run more than once in the same instance. You only need to run the WorkbookFormat sub routine from the VBE, the other macros are controlled but the shortcuts or the Submit button while in the worksheet. This works primarily from copying Roll 20 tables directly from the site; however, it can work with any table that has dice probabilities as text in the first row and the table entry in the second row using the following format: Col 1 | Col 2 01-05 | 1d6 Wolves or 1d4 Bears There isn't a ton of error handling in this. For instance it will throw codes if there is nothing to be pasted after pressing ctrl+v. It is important to clear the form using the ctrl+shift+c shortcut so you don't accidentally have leftover table data from a previous submission. It can handle table entries with up to 3 dice rolls in them. It can be expanded fairly easily but I haven't come across any tables that have more than 3 yet. Table Formatting Right now, the macro reads the range of dice from column B, and the description from column C. It was designed for copy/pasting tables from the Roll20 website, so it only reads dice ranges using the format ##-## as text. For instance, to read a range of 1-9, the correct format in Column B would be 01-09. It will then return a weight of 9 to the output column for the given item. The macro can now accommodate any numeric range. If you have any single number (e.g. 1, 27, or 19023) in the first column, the weight will return 1 as it interprets the number as a single dice roll. A range of 1-10 would return a weight of 10, etc. If you notice behavior that seems odd or incorrect, please don't hesitate to point it out; as I mentioned, I am not an expert with VBA or this subject by any means and am happy to improve this in any way. Sub WorkbookFormat()
'
' WorkbookFormat Macro
'
'
Dim Format As Object
Set Format = Worksheets(1)
With Format
.Activate
.Cells.ClearContents
.Cells.ClearFormats
.Cells.NumberFormat = "@"
Cells.Borders.LineStyle = xlLineStyleNone
Cells.Interior.Color = RGB(256, 256, 256)
Columns("A").ColumnWidth = 30
Range("A4:A99999").Interior.Color = RGB(200, 200, 200)
With Range("A1")
.Value = "Table Name"
.Font.Size = 14
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
With Range("A2")
.Borders.LineStyle = xlContinuous
.Interior.Color = RGB(230, 230, 230)
End With
With Range("A3")
.RowHeight = 60
.WrapText = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Value = "Enter a table name above, then click any cell and press ctrl+v to paste the table data. To clear press Ctrl+Shift+C"
End With
End With
Call ButtonPlace
Application.MacroOptions Macro:="pasterecord", _
ShortcutKey:="v"
Application.MacroOptions Macro:="Clear", _
ShortcutKey:="C"
End Sub
Sub pasterecord()
Dim r As Integer
Worksheets(1).Activate
Range("B1").Select
ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
DisplayAsIcon:=False
End Sub
Sub Clear()
Worksheets(1).Range("B:B").ClearContents
Worksheets(1).Range("C:C").ClearContents
Worksheets(1).Range("D:D").ClearContents
End Sub
Sub DictionaryTest()
'
'Declare integers
'
Dim r As Integer
Dim i As Integer
Dim x As Integer
'
'Declare description strings
'
Dim strDescA As String
Dim strDescB As String
Dim strDescC As String
Dim strDescD As String
Dim strNewText As String Dim strItemInput As String
'
'Declare objects for libraries: RollLen = strings for identified dice rolls, Pos = position of first character of identified dice roll
'
Dim RollLen As Object
Set RollLen = CreateObject("Scripting.Dictionary")
Dim Pos As Object
Set Pos = CreateObject("Scripting.Dictionary")
'
'Declare other variables
'
Dim strFullString As String
Dim iStringLen As Integer
Dim strTableName As String
strTableName = Worksheets(1).Range("A2").Value
'Reset integers
r = 1
i = 1
x = 0
For r = 1 To WorksheetFunction.CountA(Worksheets(1).Range("C:C"))
'Find cell content as string, find number of characters
strFullString = Worksheets(1).Range("C" & r)
iStringLen = Len(strFullString)
'Reset values for new row
x = 0
strDescA = vbNullString
strDescB = vbNullString
strDescC = vbNullString
strDescD = vbNullString
For i = 1 To iStringLen
'Find position of dice roll, increments on x if previous roll has been found
If IsNumeric(Mid(strFullString, i, 1)) = True Then
If Mid(strFullString, i + 1, 1) = "d" Then
x = x + 1
Pos(x) = i
RollLen(x) = Mid(strFullString, Pos(x), WorksheetFunction.Find(" ", strFullString, Pos(x)) - Pos(x))
End If
End If
Next i
'Separate string descriptions from dice roll text; if no dice roll found in text, return original text
If Pos(1) > 0 Then
strDescA = Left(strFullString, Pos(1) - 1)
If Pos(2) > 0 Then
strDescB = Mid(strFullString, Pos(1) + Len(RollLen(1)), Pos(2) - Pos(1) - Len(RollLen(1)))
If Pos(3) > 0 Then
strDescC = Mid(strFullString, Pos(2) + Len(RollLen(2)), Pos(3) - Pos(2) - Len(RollLen(2)) - 1)
If Pos(4) > 0 Then
strDescD = Mid(strFullString, Pos(3) + Len(RollLen(3)), Pos(4) - Pos(3) - Len(RollLen(3)) - 1)
Else
strDescD = Mid(strFullString, Pos(3) + Len(RollLen(3)), 9999)
End If
Else
strDescC = Mid(strFullString, Pos(2) + Len(RollLen(2)), 9999)
End If
Else
strDescB = Mid(strFullString, Pos(1) + Len(RollLen(1)), 9999)
End If
Else
strDescA = strFullString
End If
'
'--Optional: adds syntax for RecursiveTables. Comment out for plain text
'
For i = 1 To 5
If RollLen(i) <> "" Then
RollLen(i) = "<%%91%%><%%91%%>" & RollLen(i) & "<%%93%%><%%93%%>"
End If
Next i
'
'End optional syntax
'
'Set new text value
strNewText = strDescA & RollLen(1) & strDescB & RollLen(2) & strDescC & RollLen(3) & strDescD & RollLen(4)
'Get item weight
Dim iWeight As Integer
Dim iLeft As Integer
Dim iRight As Integer
iLeft = 0
iRight = 0
On Error Resume Next
Worksheets(1).Activate
If WorksheetFunction.IfError(WorksheetFunction.Find("-", Range("B" & r)), 0) > 0 Then
iLeft = CInt(Left(Range("B" & r), WorksheetFunction.Find("-", Range("B" & r))))
iRight = CInt(Right(Range("B" & r), Len(Range("B" & r)) - WorksheetFunction.Find("-", Range("B" & r))))
iWeight = iRight + iLeft + 1
Else
iWeight = 1
End If
On Error GoTo 0
'Set input item command
strItemInput = "!import-table-item --" & strTableName & " --" & strNewText & " --" & iWeight & " --"
Worksheets(1).Range("D" & r).Value = strItemInput
'Clear libraries
Pos.RemoveAll
RollLen.RemoveAll
Next r
'strMessage = ""
'MsgBox prompt:=strMessage
End Sub
Sub ButtonPlace()
'
' ButtonPlace Macro
'
'
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 9, 102, 144.75, 66.75). _
Select
Selection.OnAction = "DictionaryTest"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Submit"
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignLeft
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
ActiveSheet.Shapes.Range(Array("Rectangle: Rounded Corners 1")).Select
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 25
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
With Selection.ShapeRange.TextFrame2.TextRange.Font
.NameComplexScript = "Arial Nova"
.NameFarEast = "Arial Nova"
.Name = "Arial Nova"
End With
Worksheets(1).Range("A2").Select
End Sub
Hope this helps at least one person!
