CODEWITHSUNDEEP
excelvbaautofill
Henry
Henry

Reputation: 49

Autofill every n rows

How can I autofill the entirety of column B based on column A but with n empty rows in between each letter?

Column A:

a
b
c

Column B:

a
...
...
b
...
...
c

I have tried the VBA code below:

Range("A1:A3").AutoFill Destination:=Range("A1:A10"), Type:=xlFillDefault

The code works with numbers but not when the cell references a formula (in this case, =A1, ...) as the code seems to reference the row the formula is, instead of the list in column A.

For example, the code inserts the formula a row after c in B7, however would insert =A7 instead of =A4 which would be the letter d.

Any help with this would be greatly appreciated.

Upvotes: 2

Views: 619

Answers (2)

Kin Siang
Kin Siang

Reputation: 2699

To insert n row for each value in Column A, I will use offset to solve it, here is the solution and hope you find it useful:

Sub ty()

Dim count As Long, i As Long, nextrow As Long

count = Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
nextrow = 1

For i = 1 To count
    Sheet1.Cells(nextrow, 2).Value = Sheet1.Cells(i, 1).Value
    nextrow = Cells(nextrow, 2).Offset(3, 1).Row
Next

End Sub

Expected Output:

enter image description here

In order to preserve the formula into new cells, then you may need copy method` by change this part:

For i = 1 To count
    Sheet1.Cells(i, 1).Copy Sheet1.Cells(nextrow, 2)
    nextrow = nextrow + 3
Next

Upvotes: 1

VBasic2008
VBasic2008

Reputation: 54777

AutoFill Every n Rows

  • You run GetGappedColumnTEST. GetGappedColumn is being called by the GetGappedColumnTEST.
  • Adjust the values in the constants section and the workbook, and rename the Sub appropriately.
Option Explicit

Sub GetGappedColumnTEST()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "B1"
    Const dGap As Long = 2

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim Data As Variant
    Data = GetGappedColumn(wb.Worksheets(sName).Range(sFirst), dGap)
    
    If IsEmpty(Data) Then Exit Sub
    
    Dim drCount As Long: drCount = UBound(Data, 1)
    
    With wb.Worksheets(dName).Range(dFirst)
        .Resize(drCount).Value = Data
        .Resize(.Worksheet.Rows.Count - .Row - drCount + 1) _
            .Offset(drCount).ClearContents
    End With
    
End Sub

Function GetGappedColumn( _
    ByVal FirstCell As Range, _
    Optional ByVal Gap As Long = 0) _
As Variant
    Const ProcName As String = "GetGappedColumn"
    On Error GoTo clearError

    If FirstCell Is Nothing Then Exit Function
    If Gap < 0 Then Exit Function
    
    Dim srg As Range
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set srg = .Resize(lCell.Row - .Row + 1)
    End With
    Dim rCount As Long: rCount = srg.Rows.Count
       
    Dim sData As Variant
    If rCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    Dim dData As Variant: ReDim dData(1 To rCount + rCount * Gap - Gap, 1 To 1)
    Dim d As Long: d = 1
    Dim s As Long
    For s = 1 To rCount - 1
        dData(d, 1) = sData(s, 1)
        d = d + 1 + Gap
    Next s
    dData(d, 1) = sData(s, 1)

    GetGappedColumn = dData
    
ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Upvotes: 0

Related Questions