Question

这是我在Sheet1中的样本，（从B到F的数字只是= Sheet2！B2种公式）

A           B   C   D   E   F
11/12/2016  300 4   4   3   85
12/12/2016  23  4   4   2   87
13/12/2016  21  4   4   2   79
14/12/2016  67  4   4   4   76

我试图在A列下面插入接下来7天的日期（II已经实现）并因此将公式从B列拖到F.我不能使用RANGE B1：F7，因为我将在将旧的7天数据追加到新的数据中，所以我需要动态范围。

这是我的尝试，但是我在for循环中返回inRange连接（错误=范围ob object_global失败）：

Sub test()
    Dim r As Range Set r = Intersect(ActiveSheet.UsedRange,   Range("A:A")).Cells.SpecialCells(xlCellTypeBlanks)
    r(1).Formula = "=Today()"
    r(2).Formula = "=Today()+1"
    r(3).Formula = "=Today()+2"
    r(4).Formula = "=Today()+4"
    r(5).Formula = "=Today()+5"
    r(6).Formula = "=Today()+6"
    Dim inRange As Range
    Set inRange = Sheets("Sheet1").Range("B" & i & ":" & "F" & i)
    For i = 1 To 7
         Sheets("Sheet1").Range("B1:F1").Select
        Selection.AutoFill Destination:=Range(inRange), Type:=xlFillDefault

    Next i
End Sub

由于

Answer 1

也许不是世界上最好的代码，但它很快，因为它避免了循环（假设我理解了这个问题）：

Sub testit(cell as range, numberOfRows as long)
    range(cell, cell.Offset(numberOfRows)).formula = "=Today() + row() - " & cell.Row
End Sub

编辑：第二个想法我认为我误解了。这有更好的吗？

Sub testit()
    Dim k as range
    Set k = Range("B2").CurrentRegion.columns(1).SpecialCells(xlCellTypeBlanks)
    k.formula = "=Today() + row() - " & k.cells(1,1).Row
End Sub

请记住复制并粘贴为值，假设您希望数据保持这种状态。否则它也将是动态的！

Answer 2

我不会用这个：

Set r = Intersect(ActiveSheet.UsedRange, Range("A:A")).Cells.SpecialCells(xlCellTypeBlanks)

因为如果交集返回没有单元格，则会引发错误。如果此表是Sheet1中的唯一范围，则可以为了性能和文件大小而删除行。

如果范围（B1，F1）中的公式不变，我会这样编码：

Sub test()
    Dim r As Excel.Range
    Dim i As Integer

    'I wouldn't use this
    'Set r = Intersect(ActiveSheet.UsedRange, Range("A:A")).Cells.SpecialCells(xlCellTypeBlanks)

    'Instead:
    Range("A1").End(xlDown).Offset(1, 0).Activate
    ActiveCell.Formula = "=Today()"
    For i = 0 To 6
        If i = 0 Then
            ActiveCell.Formula = "=Today()"
        Else
            ActiveCell.Formula = "=Today()+" & i
        End If
        ActiveCell.Offset(1, 0).Activate
    Next i
    Range("B1:F1").Copy Intersect(ActiveSheet.UsedRange, Range("B:F")).Cells.SpecialCells(xlCellTypeBlanks)
End Sub

VBA，拖拽有空单元格的公式

2 个答案: