Saturday 4 February 2017

Static Values Script Generator

So it is really useful to initialise a Range with some static values from code, especially for Stack Overflow where if an Excel VBA question does not have data then it is not directly debuggable. When I post to Stack Overflow I want to give the responders some test data to play with. We can generate some scripts with some code (meta-code?).

Here is the standard module modStaticValuesScriptGenerator.bas It relies on tables of data being resident on sheets Players and Clubs. To solve chicken and egg problem, a script below follows which you can use first...

Attribute VB_Name = "modStaticValuesScriptGenerator"
Option Explicit

Sub TestGenerateScript()
    Dim dicScript As Scripting.Dictionary
    GenerateScript dicScript, "Players"
    GenerateScript dicScript, "Clubs"
    Debug.Print Join(dicScript.items, vbNewLine)
End Sub

Function GenerateScript(ByRef dicLines As Scripting.Dictionary, ByVal sSheetName As String) As Variant
    
    If dicLines Is Nothing Then Set dicLines = New Scripting.Dictionary
    
    'Debug.Assert sSheetName > 1

    Dim wsData As Excel.Worksheet
    Set wsData = ThisWorkbook.Worksheets.Item(sSheetName)
    
    Dim rngData As Excel.Range
    Set rngData = wsData.Cells(1, 1).CurrentRegion
    
    Dim lRowCount As Long
    lRowCount = rngData.Rows.Count
    
    Dim lColumnCount As Long
    lColumnCount = rngData.Columns.Count
    
    ReDim sRow(1 To lRowCount) As String
    
    Dim lRowLoop As Long
    For lRowLoop = 1 To lRowCount
        
        sRow(lRowLoop) = ""
        
        Dim lColumnLoop As Long
        For lColumnLoop = 1 To lColumnCount
        
            Dim rng As Excel.Range
            Set rng = rngData.Cells(lRowLoop, lColumnLoop)
            
            Dim v As Variant
            v = rng.Value2
            
            Dim v2 As Variant: v2 = Empty
            If IsNumeric(v) Then
                v2 = v
            Else
                v2 = """" & v & """"
            End If
            sRow(lRowLoop) = sRow(lRowLoop) & VBA.IIf(Len(sRow(lRowLoop)) = 0, v2, "," & v2)
            
        
        Next lColumnLoop
        
    
    Next lRowLoop
'    Stop
    
    
    Dim lRowsPerChunk As Long
    lRowsPerChunk = 5
    
    If lRowCount Mod lRowsPerChunk = 1 Then
        '* no singleton rows because we need tweo dimensional chunks
        '* so add a blank line
        
        ReDim Preserve sRow(LBound(sRow) To UBound(sRow) + 1)
        
        Dim sPad As String: sPad = ""
        'Dim lPadLoop As Long
        For lColumnLoop = 1 To lColumnCount
            sPad = sPad & VBA.IIf(Len(sPad) > 0, ",""""", """""")
        Next
        
        sRow(UBound(sRow)) = sPad
        
        lRowCount = lRowCount + 1
        
    
    End If
    
    Dim lChunks As Long
    lChunks = Int(lRowCount / lRowsPerChunk) + 1
    
    ReDim sChunks(1 To lChunks) As String
    ReDim sRow2(1 To lRowsPerChunk) As String
    'sData = ""
    For lRowLoop = 1 To lRowCount
        
        
        Dim lChunk As Long
        lChunk = ((lRowLoop - 1) \ lRowsPerChunk) + 1
        Debug.Assert lChunk <> 0
        
        Dim lChunkRow As Long
        lChunkRow = (lRowLoop Mod lRowsPerChunk)
        
        Dim lChunkRowIndex As Long
        lChunkRowIndex = VBA.IIf(lChunkRow = 0, lRowsPerChunk, lChunkRow)
        
        sRow2(lChunkRowIndex) = sRow(lRowLoop)
        
        If lRowLoop Mod lRowsPerChunk = 0 Then
            Debug.Assert sChunks(lChunk) = ""
            sChunks(lChunk) = "[{" & VBA.Join(sRow2, ";") & "}]"
            ReDim sRow2(1 To lRowsPerChunk) As String
        End If
    
    Next
    ReDim Preserve sRow2(1 To lChunkRowIndex)
    sChunks(lChunks) = "[{" & VBA.Join(sRow2, ";") & "}]"
    
    dicLines.Add dicLines.Count, "Sub Paste" & sSheetName
    dicLines.Add dicLines.Count, vbTab & "Dim sh as Excel.Worksheet: Set sh=Nothing" & vbNewLine
    dicLines.Add dicLines.Count, vbTab & "Dim v(1 to " & lChunks & ") as Variant"
    
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To lChunks
        dicLines.Add dicLines.Count, vbTab & "v(" & lChunkLoop & ")=" & sChunks(lChunkLoop)
    
    Next
    
    dicLines.Add dicLines.Count, vbTab & "Dim lRowIndex As Long: lRowIndex = 0"
    dicLines.Add dicLines.Count, vbTab & "Dim lChunkLoop As Long"
    dicLines.Add dicLines.Count, vbTab & "For lChunkLoop = 1 To " & lChunks
    dicLines.Add dicLines.Count, vbTab & "    Dim vWrite As Variant"
    dicLines.Add dicLines.Count, vbTab & "    vWrite = v(lChunkLoop)"
        
    dicLines.Add dicLines.Count, vbTab & "    Dim lChunkRowsCount As Long"
    dicLines.Add dicLines.Count, vbTab & "    lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1"
    dicLines.Add dicLines.Count, vbTab & "    sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite"

    dicLines.Add dicLines.Count, vbTab & "    lRowIndex = lRowIndex + lChunkRowsCount"

    dicLines.Add dicLines.Count, vbTab & "Next"

    dicLines.Add dicLines.Count, "End Sub "

End Function


Here is the standard module modScripts.bas It was generated by module above

Attribute VB_Name = "modScripts"
Sub PastePlayers()
    Dim sh As Excel.Worksheet: Set sh = Sheet10

    Dim v(1 To 5) As Variant
    v(1) = [{"Player","Club","Nationality","Goals";"Diego Costa","Chelsea","Spain",15;"Alexis Sánchez","Arsenal","Chile",15;"Jermain Defoe","Sunderland","England",14;"Zlatan Ibrahimovic","Manchester United","Sweden",14}]
    v(2) = [{"Romelu Lukaku","Everton","Belgium",14;"Harry Kane","Tottenham Hotspur","England",13;"Sergio Agüero","Manchester City","Argentina",11;"Dele Alli","Tottenham Hotspur","England",11;"Eden Hazard","Chelsea","Belgium",10}]
    v(3) = [{"Christian Benteke","Crystal Palace","Belgium",9;"Sadio Mané","Liverpool","Senegal",9;"Michail Antonio","West Ham United","England",8;"Roberto Firmino","Liverpool","Brazil",8;"Olivier Giroud","Arsenal","France",8}]
    v(4) = [{"Fernando Llorente","Swansea City","Spain",8;"Theo Walcott","Arsenal","England",8;"Troy Deeney","Watford","England",7;"Adam Lallana","Liverpool","England",7;"Salomón Rondón","West Bromwich Albion","Venezuela",7}]
    v(5) = [{"Gylfi Sigurdsson","Swansea City","Iceland",7;"","","",""}]
    Dim lRowIndex As Long: lRowIndex = 0
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To 5
        Dim vWrite As Variant
        vWrite = v(lChunkLoop)
        Dim lChunkRowsCount As Long
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
End Sub
Sub PasteClubs()
    Dim sh As Excel.Worksheet: Set sh = Sheet9

    Dim v(1 To 5) As Variant
    v(1) = [{"Club","Wins";"Chelsea",19;"Arsenal",14;"Manchester City",14;"Liverpool",13}]
    v(2) = [{"Tottenham Hotspur",13;"Manchester United",11;"Everton",10;"Burnley",9;"West Bromwich Albion",9}]
    v(3) = [{"West Ham United",8;"AFC Bournemouth",7;"Southampton",7;"Stoke City",7;"Watford",7}]
    v(4) = [{"Swansea City",6;"Crystal Palace",5;"Leicester City",5;"Hull City",4;"Middlesbrough",4}]
    v(5) = [{"Sunderland",4;"",""}]
    Dim lRowIndex As Long: lRowIndex = 0
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To 5
        Dim vWrite As Variant
        vWrite = v(lChunkLoop)
        Dim lChunkRowsCount As Long
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
End Sub

No comments:

Post a Comment