HiveBrain v1.2.0
Get Started
← Back to all entries
patternMinor

Optimize spreadsheet-filling routine

Submitted by: @import:stackexchange-codereview··
0
Viewed 0 times
spreadsheetroutinefillingoptimize

Problem

I'm stuck with the slow VBA routine below, which I think is the cause of lagging (taking to long). I was wondering if there is a faster way to do this:

With Sheets("Groups")
    .Cells(1, 1).Value = "Groups"
    .Cells(1, 2).Value = "Aantal"
    .Cells(2, 1).Value = "9N4"
    .Cells(2, 2).Value = n9N4
    .Cells(3, 1).Value = "1A2A"
    .Cells(3, 2).Value = n1A2A
    .Cells(4, 1).Value = "1A2B"
    .Cells(4, 2).Value = n1A2B
    .Cells(5, 1).Value = "2A2"
    .Cells(5, 2).Value = n2A2
    .Cells(6, 1).Value = "2A3"
    .Cells(6, 2).Value = n2A3
    .Cells(7, 1).Value = "2A4"
    .Cells(7, 2).Value = n2A4
    .Cells(8, 1).Value = "3A3"
    .Cells(8, 2).Value = n3A3
    .Cells(9, 1).Value = "3A4"
    .Cells(9, 2).Value = n3A4
    .Cells(10, 1).Value = "4A4"
    .Cells(10, 2).Value = n4A4
    .Cells(11, 1).Value = "1B4A"
    .Cells(11, 2).Value = n1B4A
    .Cells(12, 1).Value = "1B4B"
    .Cells(12, 2).Value = n1B4B
    .Cells(13, 1).Value = "1B4C"
    .Cells(13, 2).Value = n1B4C
    .Cells(14, 1).Value = "1B4D"
    .Cells(14, 2).Value = n1B4D
    .Cells(15, 1).Value = "2G4"
    .Cells(15, 2).Value = n2G4
    .Cells(16, 1).Value = "3G4"
    .Cells(16, 2).Value = n3G4
    .Cells(17, 1).Value = "4G4"
    .Cells(17, 2).Value = n4G4
    .Cells(18, 1).Value = "1E3"
    .Cells(18, 2).Value = n1E3
    .Cells(19, 1).Value = "1E4"
    .Cells(19, 2).Value = n1E4
    .Cells(20, 1).Value = "2E4"
    .Cells(20, 2).Value = n2E4
    .Cells(21, 1).Value = "3E3"
    .Cells(21, 2).Value = n3E3
    .Cells(22, 1).Value = "3E4"
    .Cells(22, 2).Value = n3E4
    .Cells(23, 1).Value = "4E4"
    .Cells(23, 2).Value = n4E4
    resultst = n9N4 + n1A2A + n1A2B + n2A2 + n2A3 + n3A3 + n1B4A + n1B4B + n1B4C + n1B4D + n2G4 + n3G4 + n4G4 + n2A4 + n3A4 + n4A4 + n1E3 + n1E4 + n2E4 + n3E3 + n3E4 + n4E4
    .Cells(24, 1).Value = "result"
    .Cells(24, 2).Value = resultst

'check if the sum is correct
    .Cells(24, 3).Value = "=Sum(b2:b23)"
End With


The labels are written and the values come

Solution

It's hard to say exactly how this will be implemented without seeing the entire sub/function, but what you need is a Select Case statement and a For loop.

Pseudo code to get you started:

Dim row as Long
    For row = 1 to 24
        Populate row 
    next row

End Sub

Private Sub Populate(ByVal row as Long)
     Dim text as string 
     text = GetText(row)
     Dim value as Variant
     value =  GetValue(row, text)

     Sheets("Groups").Cells(row,1) = text
     Sheets("Groups").Cells(row,2) = value
End Sub

Private Function GetText(ByVal row as Long) As String
    Select Case Row
        Case 1: GetText = "Groups"
        Case 2: GetText = "9N4"
        Case 3: GetText = "1A2A"

        'etc

     End Select
End Function

Private Function GetValue(ByVal row as Long, ByVal matchText as String) As Variant
    If row = 1 Then
        GetValue = "Aantal"
    Else
        GetValue = Application.WorksheetFunction.CountIf(Sheets("totallist").Range("G2:G" & rn_totallist), matchText)
    End If
End Function

Code Snippets

Dim row as Long
    For row = 1 to 24
        Populate row 
    next row

End Sub

Private Sub Populate(ByVal row as Long)
     Dim text as string 
     text = GetText(row)
     Dim value as Variant
     value =  GetValue(row, text)

     Sheets("Groups").Cells(row,1) = text
     Sheets("Groups").Cells(row,2) = value
End Sub

Private Function GetText(ByVal row as Long) As String
    Select Case Row
        Case 1: GetText = "Groups"
        Case 2: GetText = "9N4"
        Case 3: GetText = "1A2A"

        'etc

     End Select
End Function

Private Function GetValue(ByVal row as Long, ByVal matchText as String) As Variant
    If row = 1 Then
        GetValue = "Aantal"
    Else
        GetValue = Application.WorksheetFunction.CountIf(Sheets("totallist").Range("G2:G" & rn_totallist), matchText)
    End If
End Function

Context

StackExchange Code Review Q#59680, answer score: 4

Revisions (0)

No revisions yet.