Repeat even numbers in an array VBA

Question

I'm trying to make a macro for where a user inputs a number and the even numbers are repeated in an array. I have got the code for repeating the numbers from 0-n (n being the number inputted). However, I don't know how to go about repeating the even numbers twice.

Sub Macro3()

For n = 1 To Worksheets("Sheet1").Cells(1, 2) + 1

    Cells(2, 1 + n).Select
    ActiveCell.FormulaR1C1 = (n - 1)
    
Next

End Sub

Below is the output Current code vs what I really want

Answer 1

Write an Array of Integers

• Writes an array of integers between 0 and the specified value in cell B1 to a row range starting from B2. Even numbers are written twice (one worksheet).

Initial Solution

• This is a slow solution meant to be educational in understanding object variables (workbook-worksheet-range), ranges (Resize, Offset), loops,...

Option Explicit

Sub WriteArrayOfIntegersRange()
    Const ProcTitle As String = "Write Array of Integers Range"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    
    ' Create a reference to the source cell.
    Dim sCell As Range: Set sCell = ws.Range("B1")
    
    ' Write the value of the source cell to a variable.
    Dim sValue As Variant: sValue = sCell.Value
    
    Dim LastInteger As Long
    
    ' Validate the source cell value.
    If IsNumeric(sValue) Then ' is a number
        LastInteger = Abs(CLng(sValue)) ' positive ('Abs'), whole ('CLng')
    Else ' is not a number
        MsgBox "The value in cell '" & sCell.Address(0, 0) & "' ('" _
            & sValue & "' is not a number.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    ' Create a reference to the first destination cell.
    Dim dCell As Range: Set dCell = ws.Range("B2"): dCell.Value = 0
    
    Dim Size As Long: Size = 1
    
    Dim n As Long
    
    ' Loop through the numbers and apply alternating row size (1 or 2)
    ' and column offset (2 or 1) before writing.
    For n = 1 To LastInteger
        Set dCell = dCell.Offset(, Size) ' define next first cell
        Size = 2 - n Mod 2 ' calculate the size (Odd = 1, Even = 2)
        dCell.Resize(, Size).Value = n ' write to the resized row range
    Next n
    
    ' Clear the range to the right of the last cell to remove any previous data.
    Dim crrg As Range
    With dCell.Offset(, Size) ' define next first cell
        ' Define the range from the next first to the last worksheet cell
        ' in the row.
        Set crrg = .Resize(, ws.Columns.Count - .Column + 1)
    End With
    crrg.Clear ' or crrg.ClearContents
    
    MsgBox "Array of numbers written.", vbInformation, ProcTitle

End Sub

Using Arrays

• This is a more advanced solution that utilizes the multi-purpose GetArrayOfIntegers function. By modifying the related constants (Function Parameters) in the following procedure, you can easily change the output.
• Note that it returns the results in another worksheet (Sheet2).
• The last procedure is created for anyone to quickly get a flavor of the GetArrayOfIntegers function. Just add a new workbook, add a new module and copy the codes to it. Modify the function parameters in the last procedure to get different results in the Immediate window (Ctrl+G).

Sub WriteArrayOfIntegers()
' Needs the 'GetArrayOfIntegers' function.
    Const ProcTitle As String = "Write Array of Numbers"
    ' Source
    Const sName As String = "Sheet1"
    Const sCellAddress As String = "B1"
    ' Destination
    Const dName As String = "Sheet2"
    Const dfCellAddress As String = "B2"
    ' Function Parameters ' experiment with these five parameters
    Const EvensCount As Long = 2
    Const OddsCount As Long = 1
    Const DoReturnRow As Boolean = True
    Const IncludeZero As Boolean = True
    Const IsZeroOdd As Boolean = True
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the source cell.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sCell As Range: Set sCell = sws.Range(sCellAddress)
    
    ' Write the value of the source cell to a variable.
    Dim sValue As Variant: sValue = sCell.Value
    
    Dim LastInteger As Long
    
    ' Validate the source cell value.
    If IsNumeric(sValue) Then ' is a number
        LastInteger = Abs(CLng(sValue)) ' positive ('Abs'), whole ('CLng')
    Else ' is not a number
        MsgBox "The value in cell '" & sCell.Address(0, 0) & "' ('" _
            & sValue & "' is not a number.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    ' Return the result (an array) of the 'GetArrayOfIntegers' function.
    Dim Data As Variant: Data = GetArrayOfIntegers( _
        LastInteger, EvensCount, OddsCount, DoReturnRow, IncludeZero, IsZeroOdd)
    ' Without the constants it would be:
    'Data = GetArrayOfIntegers(LastInteger, 2, 1, True, True, True)
    If IsEmpty(Data) Then Exit Sub
    
    Dim drCount As Long: drCount = UBound(Data, 1)
    Dim dcCount As Long: dcCount = UBound(Data, 2)
    
    ' Create a reference to the first destination cell.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dfCellAddress)
    
    ' Clear all cells next to (to the right of) and below
    ' the first destination cell.
    Dim dcrg As Range: Set dcrg = dfCell.Resize( _
        dws.Rows.Count - dfCell.Row + 1, dws.Columns.Count - dfCell.Column + 1)
    dcrg.Clear ' or dcrg.ClearContents
    
    ' Create a reference to the destination range.
    Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
    
    ' Write the values from the array to the destination range.
    drg.Value = Data
    
    MsgBox "Array of numbers written.", vbInformation, ProcTitle

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Author:       VBasic2008
' Dates:        20211101
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns an array of integers in a 2D one-based array.
' Remarks:      The first element is always 0 or 1.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetArrayOfIntegers( _
    ByVal LastInteger As Long, _
    Optional ByVal EvensCount As Long = 1, _
    Optional ByVal OddsCount As Long = 1, _
    Optional ByVal DoReturnRow As Boolean = False, _
    Optional ByVal IncludeZero As Boolean = False, _
    Optional ByVal IsZeroOdd As Boolean = False) _
As Variant
    
    Dim eoArr() As Long: ReDim eoArr(0 To 1)
    eoArr(0) = EvensCount: eoArr(1) = OddsCount
    
    Dim zCount As Long
    If IncludeZero Then
        If IsZeroOdd Then zCount = OddsCount Else zCount = EvensCount
    End If
    
    Dim iMod As Long: iMod = LastInteger Mod 2
    Dim eCount As Long: eCount = Int(LastInteger / 2)
    Dim oCount As Long: oCount = Int(LastInteger / 2) + iMod
    
    Dim dtCount As Long
    dtCount = eCount * EvensCount + oCount * OddsCount + zCount
    
    Dim Data As Variant
    Dim dt As Long: dt = 1
    Dim n As Long
    Dim r As Long
    
    If DoReturnRow Then
        ReDim Data(1 To 1, 1 To dtCount)
        If zCount > 0 Then
            For dt = 1 To zCount: Data(1, dt) = 0: Next dt
        End If
        For n = 1 To LastInteger
            For r = 1 To eoArr(n Mod 2)
                Data(1, dt) = n
                dt = dt + 1
            Next r
        Next n
    Else
        ReDim Data(1 To dtCount, 1 To 1)
        If zCount > 0 Then
            For dt = 1 To zCount: Data(dt, 1) = 0: Next dt
        End If
        For n = 1 To LastInteger
            For r = 1 To eoArr(n Mod 2)
                Data(dt, 1) = n
                dt = dt + 1
            Next r
        Next n
    End If
    
    GetArrayOfIntegers = Data

End Function

' This is an unrelated example to play with.
' Note that changing the fourth parameter will make no difference since
' the results are written to the Immediate window (Ctrl+G).
Sub GetArrayOfIntegersTEST()
' Needs the 'GetArrayOfIntegers' function.
    Dim Data As Variant: Data = GetArrayOfIntegers(4, 3, 2, False, False, False)
    Dim r As Long, c As Long
    For r = 1 To UBound(Data, 1)
        For c = 1 To UBound(Data, 2)
            Debug.Print Data(r, c)
        Next c
    Next r
End Sub

Answer 2

Fast alternative via ArrayList

Working with an ArrayList (disposing btw of methods like .Sort,.Remove, .Insert, .Reverse) may be a convenient way to manipulate array data in a very readable way. It is not part of VBA, but can be accessed easily via late binding (referring to .Net library mscorlib.dll).

Option Explicit                          ' code module head

Sub DoubleEvenNumbersGreaterOne()
'a) define upper limit
    Dim ws As Worksheet
    Set ws = Sheet1                       ' << change to project's sheet Code(Name)
    Dim Limit As Long
    Limit = ws.Range("B1")
'b) declare ArrayList 
    Dim arr As Object                     ' late bind .Net mscorlib.dll
    Set arr = CreateObject("System.Collections.ArrayList")  
'c) populate list array
    arr.Add 0                             ' start adding with zero
    Dim i As Long
    For i = 1 To Limit                    ' loop through sequence 1:Limit
        arr.Add i                         ' add current number
        If i Mod 2 = 0 Then arr.Add i     ' additional even number
    Next
'd) get array 
    Dim a As Variant: a = arr.ToArray     ' change ArrayList object to VBA array
    'Debug.Print Join(a, "|")             ' optional check in VB Editor's immediate window
'e) write 0-based 1-dim array to ws (here: Sheet1) or declare another target worksheet (e.g. ws2)
    With ws.Range("B2")
        .EntireRow = vbNullString        ' empty target row
        .Resize(1, UBound(a) + 1) = a    ' write values into correct number of cells
    End With
End Sub

---

A formula oriented approach // late edit as of 11/1 2021

a) A first and very elementary way would be to

• enter formula =COLUMN(A1)-INT((COLUMN(A1)+2)/3) into cell B2 and to
• copy into the right neighbour cells as long as you get the wanted maximum

b) Refining this approach you can code the following udf accepting the wanted maximum as argument (note that I changed the flat Column reference to a vertical Row reference to simplify calculation of the actual maxima):

Function Sequ(ByVal maxNo As Long)
    Dim myFormula As String
    myFormula = Replace("=ROW(1:$)-INT((ROW(1:$)+2)/3)", "$", maxNo + maxNo \ 2 + 1)
    Sequ = Application.Transpose(Evaluate(myFormula))
End Function

A direct formula entry of e.g. =Sequ(10) into B2 benefitting from the newer dynamic features of vers. 2019+/MS 365 would display all (row) elements automatically in a so called spill range without need of further inputs.

Using VBA to display results in VB Editor's immediate window could be coded as follows: Debug.Print Join(Sequ(10), "|") resulting in

0|1|2|2|3|4|4|5|6|6|7|8|8|9|10|10

or to assign the results to a variable that can be used in further code.

Answer 3

Try this code

Sub Test()
    Dim v, ws As Worksheet, i As Long, ii As Long, n As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    v = ws.Range("B1").Value
    If Not IsNumeric(v) Or IsEmpty(v) Then MsgBox "Must Be Number", vbExclamation: Exit Sub
    ReDim a(1 To (v / 2) + v)
    For i = 1 To v
        If i Mod 2 = 0 Then
            For ii = 1 To 2
                n = n + 1: a(n) = i
            Next ii
        Else
            n = n + 1: a(n) = i
        End If
    Next i
    Range("C2").Resize(, UBound(a)).Value = a
End Sub