VBA – Tips & Tricks

VBA – Create and add items to dynamic arrays

This posts shows two things: Its shows how to find a value in a sheet without looping, and instead using the functions .Find and .CountIf, and how to create and add items to a dynamic array.

The problem I faced was that I had some answers to questions in a worksheet, and some of those answers had to be added as answers to questions in another worksheet. But the users in the original worksheet had in some cases added new questions and answers (rows and columns) to the questions, so I couldn’t just copy and paste it without chekcing the content and making sure the answers were posted along side the correct questions.

So, the code below first defines the questions I want to find, then finds the questions in the worksheet and saves the answers to a dynamic array. The next step is of course to add the answers to the other workwheet, and to transfer the questions and answers added by the user, but it’s not part of the example.

 

Dim Questions As Variant
Dim x As Integer
Dim myrow As Integer
Dim myColumn As Integer
Dim myValue

Dim Answers() As String    'Array of answers
Dim lngPosition As Long    'Counting
blDimensioned = False

'Array of questions
Questions = Array("Navn", "Ansat i fleksjob - Dato?", "Ansat den", "Bevillingsdato", "Evt. ophørsdato", "Kommune", "Tilskudsberettiget lønindplacering i SLS ")

'Go through the array of questions
'We want to find each of them in the worksheet

For x = LBound(Questions) To UBound(Questions)


Dim rowFound, columnFound

'If the question is not found in the worksheet, then just skip to the next item in the array
If WorksheetFunction.CountIf(Cells, Questions(x)) = 0 Then
GoTo NotFound
End If


'Find the x item in the array
Cells.Find(What:=(Questions(x)), After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate

'Found: Get the row and the column number of the answe to the question (the next column after the question
myrow = ActiveCell.row
myColumn = ActiveCell.Column + 1
myValue = Cells(myrow, myColumn)

'We have the answer.
'Add the answer to the the Answer array.

If myValue = "" Then myValue = " "
              
        'The array is dimensioned in the first loop
        If blDimensioned = True Then
                  
            'The array is extended, so we extend the array
            ReDim Preserve Answers(0 To UBound(Answers) + 1) As String
                      
        Else
                  
            'The array is not dimensined, so we dimension it and flag it as dimensioned.
            ReDim Answers(0 To 0) As String
            blDimensioned = True
                      
        End If
                  
        'Add the answer to the last element of the array
        Answers(UBound(Answers)) = myValue



NotFound:

Next x