Convert VBA code to useable formula?

MattDiptera

New Member
Joined
Mar 3, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi

Would it be possible to convert a VBA code into a function that i can insert into a cell? Struggling to get my head around VBA. In a nut shell this code should convert a grid reference in a Tetrad (2x2km). I have managed to create the formula to create a Hectad (10x10km) and also a Monad (1x1km) via string manipulation however a Tetrad ends in a letter instead of just knocking off x and y numbers so is a bit more complicated.

Here is the VBA code (Written by Graham French, NBN Trust September 2008), thanks in advance if anyone is able to offer an insight in how i do this.

VBA Code:
Public Function ConvertGRto2KM(GridRef As String)

Dim strGridref As String

strGridref = GridRef

Select Case Len(strGridref)
    'BRITISH GRID REFERENCE
    Case Is = 4
       'British 10 km grid ref return blank
       If InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(strGridref, 2, 1), vbTextCompare) <> 0 Then
            strGridref = ""
        Else
        'Irish Tetrad
        strGridref = strGridref
       End If
    Case Is = 6     '1km
        strGridref = Left(strGridref, 3) & Mid(strGridref, 5, 1) & _
                    Get_Letter(Mid(strGridref, 4, 1) & Right(GridRef, 1))
    Case Is = 8     '100m
        strGridref = Left(strGridref, 3) & Mid(strGridref, 6, 1) & _
                    Get_Letter(Mid(strGridref, 4, 1) & Mid(GridRef, 7, 1))
    Case Is = 10    '10m
       strGridref = Left(strGridref, 3) & Mid(strGridref, 7, 1) & _
                    Get_Letter(Mid(strGridref, 4, 1) & Mid(GridRef, 8, 1))
    Case Is = 12    '1m
          strGridref = Left(strGridref, 3) & Mid(strGridref, 8, 1) & _
                    Get_Letter(Mid(strGridref, 4, 1) & Mid(GridRef, 9, 1))
    'IRISH GRID REFERENCE
    Case Is = 3     '10 km
        strGridref = ""
    Case Is = 5
        'British Tetrad
        If InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(strGridref, 2, 1), vbTextCompare) <> 0 Then
            strGridref = strGridref
        Else
        'Irish 1km
             strGridref = Left(strGridref, 2) & Mid(strGridref, 4, 1) & _
                    Get_Letter(Mid(strGridref, 3, 1) & Right(GridRef, 1))
        End If
    Case Is = 7    '100m
        strGridref = Left(strGridref, 2) & Mid(strGridref, 5, 1) & _
                    Get_Letter(Mid(strGridref, 3, 1) & Mid(GridRef, 6, 1))
    Case Is = 9    '10m
        Case Is = 10    '10m
       strGridref = Left(strGridref, 2) & Mid(strGridref, 6, 1) & _
                    Get_Letter(Mid(strGridref, 3, 1) & Mid(GridRef, 7, 1))
    Case Is = 11    '1m
         strGridref = Left(strGridref, 2) & Mid(strGridref, 7, 1) & _
                    Get_Letter(Mid(strGridref, 3, 1) & Mid(GridRef, 8, 1))
    Case Else       'Do not convert
        strGridref = ""
End Select

ConvertGRto2KM = strGridref

End Function

Public Function Get_Letter(Position As String) As String

Select Case Position
    Case "00", "10", "01", "11"
        Get_Letter = "A"
    Case "20", "30", "21", "31"
        Get_Letter = "F"
    Case "40", "50", "41", "51"
        Get_Letter = "K"
    Case "60", "70", "61", "71"
        Get_Letter = "Q"
    Case "80", "90", "81", "91"
        Get_Letter = "V"
    Case "02", "12", "03", "13"
        Get_Letter = "B"
    Case "22", "32", "23", "33"
        Get_Letter = "G"
    Case "42", "52", "43", "53"
        Get_Letter = "L"
    Case "62", "72", "63", "73"
        Get_Letter = "R"
    Case "82", "92", "83", "93"
        Get_Letter = "W"
    Case "04", "14", "05", "15"
        Get_Letter = "C"
    Case "24", "34", "25", "35"
        Get_Letter = "H"
    Case "44", "54", "45", "55"
        Get_Letter = "M"
    Case "64", "74", "65", "75"
        Get_Letter = "S"
    Case "84", "94", "85", "95"
        Get_Letter = "X"
    Case "06", "16", "07", "17"
        Get_Letter = "D"
    Case "26", "36", "27", "37"
        Get_Letter = "I"
    Case "46", "56", "47", "57"
        Get_Letter = "N"
    Case "66", "76", "67", "77"
        Get_Letter = "T"
    Case "86", "96", "87", "97"
        Get_Letter = "Y"
    Case "08", "18", "09", "19"
        Get_Letter = "E"
    Case "28", "38", "29", "39"
        Get_Letter = "J"
    Case "48", "58", "49", "59"
        Get_Letter = "P"
    Case "68", "78", "69", "79"
        Get_Letter = "U"
    Case "88", "98", "89", "99"
        Get_Letter = "Z"
End Select

End Function
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

mikerickson

MrExcel MVP
Joined
Jan 15, 2007
Messages
23,948
Have you tried putting =ConvertGRto2KM(A1) in a cell and putting values in A1.
 

MattDiptera

New Member
Joined
Mar 3, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Have you tried putting =ConvertGRto2KM(A1) in a cell and putting values in A1.
Doesn't appear to be a function, the Tetrad system is not a widely used system so a ready to roll function isn't available "A tetrad is a 2km x 2km square, given a letter code as shown below. So tetrad SW41A is made up of the four 1km squares SW4010, SW4011, SW4110 and SW4111."
 

mikerickson

MrExcel MVP
Joined
Jan 15, 2007
Messages
23,948
If you put the code from the OP into a normal module of the workbook in quesiton, that formula should return something.
 

Watch MrExcel Video

Forum statistics

Threads
1,126,928
Messages
5,621,639
Members
415,849
Latest member
PhoenixRising2015

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top