CODEWITHSUNDEEP
excelvbscriptadodbvba
chris
chris

Reputation: 33

VBScript: ADODB Connection to Excel Variable Range

I've got some working code here that I'm trying to improve with an integer to alphabet solution.

I have a massive Excel Spreadsheet that the user will address with ADODB to a specific Range based on their input (to reduce the recordset size).

So, if the input is 1 the range is A1:H51 and if the input is 2, its offset by 8 fields.

Right now, as you can see below, I'm just doing 50 If Then Statements. My question is how can I use a variable to set the range based on the input?

Or is it good enough as is? Seems complicated...

Dim SelectedSpreadsheetFromTxt
Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set file = fso.OpenTextFile("C:\ProgramData\vizrt\Trio\GolfShotSheetSpreadsheetPath.txt")
    line = file.ReadLine
    file.Close

SelectedSpreadsheetFromTxt = line

Dim Message,Flag,Name,Score,Hole,Par,Shot,NullField
Dim objConnection, objRecordSet

    set objConnection = CreateObject("ADODB.Connection")
    set objRecordSet = CreateObject("ADODB.Recordset")

    objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" &_
    "Data Source=" & SelectedSpreadsheetFromTxt & ";" &_
    "Extended Properties=""Excel 12.0; HDR=Yes; IMEX=1"";"

'inputbox to ask for sheet number
Dim SheetFromInput
SheetFromInput = InputBox("What Shot Sheet?" & vbNewLine & "Enter the Number: 1,2,3,4,5, etc...","Shot Sheet")

Dim ShotRange
If SheetFromInput = 1 Then
    ShotRange = "Shot_Graphics$A1:H51" 
End If
If SheetFromInput = 2 Then
    ShotRange = "Shot_Graphics$I1:P51"
End If
If SheetFromInput = 3 Then
    ShotRange = "Shot_Graphics$Q1:X51"
End If
If SheetFromInput = 4 Then
    ShotRange = "Shot_Graphics$Y1:AF51"
End If
If SheetFromInput = 5 Then
    ShotRange = "Shot_Graphics$AG1:AN51"
End If
If SheetFromInput = 6 Then
    ShotRange = "Shot_Graphics$AO1:AV51"
End If
If SheetFromInput = 7 Then
    ShotRange = "Shot_Graphics$AW1:BD51"
End If
If SheetFromInput = 8 Then
    ShotRange = "Shot_Graphics$BE1:BL51"
End If
If SheetFromInput = 9 Then
    ShotRange = "Shot_Graphics$BM1:BT51"
End If
If SheetFromInput = 10 Then
    ShotRange = "Shot_Graphics$BU1:CB51"
End If
If SheetFromInput = 11 Then
    ShotRange = "Shot_Graphics$CC1:CJ51"
End If
If SheetFromInput = 12 Then
    ShotRange = "Shot_Graphics$CK1:CR51"
End If
If SheetFromInput = 13 Then
    ShotRange = "Shot_Graphics$CS1:CZ51"
End If
If SheetFromInput = 14 Then
    ShotRange = "Shot_Graphics$DA1:DH51"
End If
If SheetFromInput = 15 Then
    ShotRange = "Shot_Graphics$DI1:DP51"
End If
If SheetFromInput = 16 Then
    ShotRange = "Shot_Graphics$DQ1:DX51"
End If
If SheetFromInput = 17 Then
    ShotRange = "Shot_Graphics$DY1:EF51"
End If
If SheetFromInput = 18 Then
    ShotRange = "Shot_Graphics$EG1:EN51"
End If
If SheetFromInput = 19 Then
    ShotRange = "Shot_Graphics$EO1:EV51"
End If
If SheetFromInput = 20 Then
    ShotRange = "Shot_Graphics$EW1:FD51"
End If
If SheetFromInput = 21 Then
    ShotRange = "Shot_Graphics$FE1:FL51"
End If
If SheetFromInput = 22 Then
    ShotRange = "Shot_Graphics$FM1:FT51"
End If
If SheetFromInput = 23 Then
    ShotRange = "Shot_Graphics$FU1:GB51"
End If
If SheetFromInput = 24 Then
    ShotRange = "Shot_Graphics$GC1:GJ51"
End If
If SheetFromInput = 25 Then
    ShotRange = "Shot_Graphics$GK1:GR51"
End If
If SheetFromInput = 26 Then
    ShotRange = "Shot_Graphics$GS1:GZ51"
End If
If SheetFromInput = 27 Then
    ShotRange = "Shot_Graphics$HA1:HH51"
End If
If SheetFromInput = 28 Then
    ShotRange = "Shot_Graphics$HI1:HP51"
End If
If SheetFromInput = 29 Then
    ShotRange = "Shot_Graphics$HQ1:HX51"
End If
If SheetFromInput = 30 Then
    ShotRange = "Shot_Graphics$HY1:IF51"
End If
If SheetFromInput = 31 Then
    ShotRange = "Shot_Graphics$IG1:IN51"
End If
If SheetFromInput = 32 Then
    ShotRange = "Shot_Graphics$IO1:IV51"
End If
If SheetFromInput = 33 Then
    ShotRange = "Shot_Graphics$IW1:JD51"
End If
If SheetFromInput = 34 Then
    ShotRange = "Shot_Graphics$JE1:JL51"
End If
If SheetFromInput = 35 Then
    ShotRange = "Shot_Graphics$JM1:JT51"
End If
If SheetFromInput = 36 Then
    ShotRange = "Shot_Graphics$JU1:KB51"
End If
If SheetFromInput = 37 Then
    ShotRange = "Shot_Graphics$KC1:KJ51"
End If
If SheetFromInput = 38 Then
    ShotRange = "Shot_Graphics$KK1:KR51"
End If
If SheetFromInput = 39 Then
    ShotRange = "Shot_Graphics$KS1:KZ51"
End If
If SheetFromInput = 40 Then
    ShotRange = "Shot_Graphics$LA1:LH51"
End If
If SheetFromInput = 41 Then
    ShotRange = "Shot_Graphics$LI1:LP51"
End If
If SheetFromInput = 42 Then
    ShotRange = "Shot_Graphics$LQ1:LX51"
End If
If SheetFromInput = 43 Then
    ShotRange = "Shot_Graphics$LY1:MF51"
End If
If SheetFromInput = 44 Then
    ShotRange = "Shot_Graphics$MG1:MN51"
End If
If SheetFromInput = 45 Then
    ShotRange = "Shot_Graphics$MO1:MV51"
End If
If SheetFromInput = 46 Then
    ShotRange = "Shot_Graphics$MW1:ND51"
End If
If SheetFromInput = 47 Then
    ShotRange = "Shot_Graphics$NE1:NL51"
End If
If SheetFromInput = 48 Then
    ShotRange = "Shot_Graphics$NM1:NT51"
End If
If SheetFromInput = 49 Then
    ShotRange = "Shot_Graphics$NU1:OB51"
End If
If SheetFromInput = 50 Then
    ShotRange = "Shot_Graphics$OC1:OJ51"
End If

        objRecordSet.Open "SELECT * FROM [" & ShotRange & "]", objConnection

            MessageColumn = 0
            FlagColumn = 1
            NameColumn = 2
            ScoreColumn = 3
            HoleColumn = 4
            ParColumn = 5
            ShotColumn = 6
            NullFieldColumn = 7

    Do Until objRecordSet.EOF       
            Message = objRecordSet.Fields.Item(0)
            Flag = objRecordSet.Fields.Item(1)
            Name = objRecordSet.Fields.Item(2)
            Score = objRecordSet.Fields.Item(3)
            Hole = objRecordSet.Fields.Item(4)
            Par = objRecordSet.Fields.Item(5)
            Shot = objRecordSet.Fields.Item(6)
            NullField = objRecordSet.Fields.Item(7)

                TrioCmd("page:read_template SHOT_STROKEPLAY-FULL_GOLF")
                TrioCmd("page:set_property 0100 " & Flag)
                TrioCmd("page:set_property 0102 " & NullField)
                TrioCmd("page:set_property 0140 " & Name)
                TrioCmd("page:set_property 0150 " & Score)
                TrioCmd("page:set_property 0210 " & Hole)
                TrioCmd("page:set_property 0220 " & Par)
                TrioCmd("page:set_property 0230 " & Shot)
                TrioCmd("page:set_property 0320 " & NullField)
                TrioCmd("page:set_property 0330 " & NullField)
                TrioCmd("page:set_property 0410 " & NullField)
                TrioCmd("page:set_property 0510 " & NullField)
                TrioCmd("page:saveas " & Message)
    objRecordSet.MoveNext
    Loop

    objRecordSet.Close
    set objRecordSet = Nothing

    objConnection.Close
    set objConnection = Nothing

Upvotes: 1

Views: 123

Answers (1)

Sorceri
Sorceri

Reputation: 8033

If you opened the workbook then you could have used the offset function of the range object. Then you could do something like

baseRange = Range("A1:H51")

If SheetFromInput > 1 Then
    ShotRange = baseRange.Offset(0, (SheetFromInput - 1) * 8)
Else
    ShotRange = baseRange
End If

but since you are doing a query then you need to create the function to get the alpha characters. You do this by using the ascii values for A-Z:65-90. Dividing by 26 and starting at 64 since 1 = A and 64+1 is the aschii value for A.

*Note that this is not fully tested and could probably be done more efficiently

If SheetFromInput > 1 Then
    ShotRange = "Shot_Graphics$" & getRangeAlpha((SheetFromInput - 1) * 8 + 1) & "1:" & getRangeAlpha((SheetFromInput - 1) * 8 + 8) & "51"
Else
    ShotRange = "Shot_Graphics$" & getRangeAlpha(1) & "1:" & getRangeAlpha(8) & "51"
End If




Function getRangeAlpha(val)
'Ascii 65-90 A-Z
'divide by 26
Dim numLetters
Dim numRemainingLetters
Dim letterRange

numLetters = val \ 26
numRemainingLetters = val Mod 26
'check to see if we are at ZZ (702)
'we do this as 27 returns AA in this function.  This is the only known issue.
If numLetters = 27 Then
    getRangeAlpha = "ZZ"
    Exit Function
End If
'check to see if we have three letters
If numLetters > 26 Then
    Dim numThirdLetter
    'get the value for the third letter (first in series)
    numThirdLetter = numLetters \ 26
    'set the next letter to the remaining value
    numLetters = numLetters Mod 26
    'add the letter
    letterRange = Chr(64 + numThirdLetter)
End If

If numLetters > 0 Then
    letterRange = letterRange + Chr(64 + numLetters)
End If
If numRemainingLetters > 0 Then
    letterRange = letterRange + Chr(64 + numRemainingLetters)
End If

getRangeAlpha = letterRange
End Function

Upvotes: 2

Related Questions