每 n 行自动填充

如何解决每 n 行自动填充

如何根据 A 列自动填充整个 B 列，但每个字母之间有 n 个空行？

Column A:

a
b
c

Column B:

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

我已经尝试了下面的 VBA 代码：

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

代码适用于数字，但不适用于单元格引用公式（在本例中为 =A1,...），因为代码似乎引用了公式所在的行，而不是 A 列中的列表.

例如，代码在 c 中的 B7 后插入一行公式，但是会插入 =A7 而不是 =A4，后者是字母 {{1} }.

对此的任何帮助将不胜感激。

解决方法

要为 A 列中的每个值插入 n row，我将使用 offset 来解决它，这是解决方案，希望您觉得它有用：

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

预期输出：

为了将公式保存到新单元格中，您可能需要通过更改此部分来copy方法`：

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

,

每 n 行自动填充

• 您运行 GetGappedColumnTEST。 GetGappedColumn 正在被 GetGappedColumnTEST 调用。
• 调整常量部分和工作簿中的值，并适当地重命名 Sub。

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)

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