Displaying Repeated Array in a Range VBA-CodePudding

I have an array with 7 distinct string values which i need to display in one "A" column repeatedly to the last row (last row is the last of the 7 distinct array value). Last row is the last row of column "E". When I try the for Step 7 method, it only displays the 7th distinct array value.

I need to basically paste the 7 distinct array values repeatedly in sequence until the last row of column "E". Thank you!:) [screenshot][1]

example in one column:

1 2 3 4 5 6 7 1 2 3 4 5 6 7 1 2 3 4 5 6 7

    Sub NeedHelpwithPastingArray()
    
    Dim wb As Workbook
    Set wb = Workbooks("Book1")
    Dim ws As Worksheet
    Dim lr As Long
    Dim i As Long
    Dim activity(1 To 7) As String
    
    activity(1) = "1"
    activity(2) = "2"
    activity(3) = "3"
    activity(4) = "4"
    activity(5) = "5"
    activity(6) = "6"
    activity(7) = "7"
    
    
    
    Set ws = wb.Sheets("Sheet1")
    
    lr = ws.Range("e" & Rows.Count).End(xlUp).Row
    
    
    For i = 1 To lr Step 3
    
    ws.Range("a" & i) = Application.Index(activity, 1, Array(1, 2, 3, 4, 5, 6, 7))
    
    Next i
    
        
    
    End Sub


  [1]: https://i.stack.imgur.com/mnFgs.png

CodePudding user response：

Thank you so much! you answered my question. How do I give you credit? lol

Sub NeedHelpwithPastingArray()

Dim wb As Workbook
Set wb = Workbooks("Book1")
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Dim activity(1 To 7) As String

activity(1) = "1"
activity(2) = "2"
activity(3) = "3"
activity(4) = "4"
activity(5) = "5"
activity(6) = "6"
activity(7) = "7"



Set ws = wb.Sheets("Sheet1")

lr = ws.Range("e" & Rows.Count).End(xlUp).Row


For i = 1 To lr Step 3

ws.Range("a" & i).resize(7,1).value = application.transpose(activity)

Next i

    

End Sub

CodePudding user response：

Fill With Strings

Adjust (play with) the values in the constants section.

Sub FillWithStrings()
    
    Const wsName As String = "Sheet1"
    Const sFirstCellAddress As String = "E1"
    Const dCol As String = "A"
    
    Const StringsList As String = "1,2,3,4,5,6,7"
    Const StringsDelimiter As String = ","
    
    ' Reference the first cell.
    Dim wb As Workbook: Set wb = ThisWorkbook  ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim sfCell As Range: Set sfCell = ws.Range(sFirstCellAddress)
    
    ' Attempt to reference the last non-empty cell.
    Dim slCell As Range: Set slCell = sfCell.Resize( _
        ws.Rows.Count - sfCell.Row   1).Find("*", , xlFormulas, , , xlPrevious)
    If slCell Is Nothing Then
        MsgBox "No data in column range. No action taken.", vbCritical
        Exit Sub
    End If
    
    ' Calculate the number of rows.
    Dim rCount As Long: rCount = slCell.Row - sfCell.Row   1
    
    ' Write the strings from the list to an array.
    Dim Strings() As String: Strings = Split(StringsList, StringsDelimiter)
    Dim sUpper As Long: sUpper = UBound(Strings)
    Dim sCount As Long: sCount = sUpper   1
    
    ' Define the destination (resulting) array.
    Dim dData() As String: ReDim dData(1 To rCount, 1 To 1)
    
    ' Calculate how many times all the strings fit in the number of rows.
    Dim IntCount As Long: IntCount = Int(rCount / sCount)
    
    ' Write to the array.
    
    Dim i As Long
    Dim s As Long
    Dim dr As Long
    
    For i = 1 To IntCount
        For s = 0 To sUpper
            dr = dr   1
            dData(dr, 1) = Strings(s)
        Next s
    Next i
    
    ' Calculate the remainder.
    Dim ModCount As Long: ModCount = rCount Mod sCount
    
    ' Write the remainder to the array.
    For s = 0 To ModCount - 1
        dr = dr   1
        dData(dr, 1) = Strings(s)
    Next s
            
    ' Write to the worksheet.
    With sfCell.EntireRow.Columns(dCol) ' destination first cell
        ' Write from the array to the destination column range.
        .Resize(rCount).Value = dData
        ' Clear below.
        .Resize(ws.Rows.Count - .Row - rCount   1).Offset(rCount).Clear
    End With
    
    ' Inform.
    MsgBox "Column '" & dCol & "' filled with the following strings:" _
        & vbLf & vbLf & Join(Strings, vbLf), vbInformation, "Fill With Strings"
    
End Sub