VBA, nach unten ziehen Formel wo es leere Zellen

Question

Dies ist meine Probe in Sheet1 (Zahlen von B bis F sind einfach = Tabelle2! B2 Art der Formel)

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 

Ich versuche, unterhalb der einfügen Spalte A die Daten der nächsten 7 Tage (die ich erreicht habe) und die Formel von Spalte B nach F ziehen. Ich kann RANGE B1: F7 nicht verwenden, weil ich in der Woche die neuen 7 Tage an die alten Daten anhängen werde , also brauche ich dynamische Bereiche.

Hier ist mein Versuch, aber kehre ich auf dem InRange concatentation in der for-Schleife (Error = Bereichs ob object_global nicht):

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 

Dank

Answer 1

Ich würde dies nicht verwenden:

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

Denn wenn die Kreuzung keine Zellen zurückkehrt, wird er einen Fehler machen. Und wenn diese Tabelle der einzige Bereich in Sheet1 ist, gibt es Zeilen, die Sie aus Gründen der Leistung und Dateigröße löschen können.

Wenn die Formeln im Bereich (B1, F1) nicht ändern, würde ich es auf diese Weise Code:

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 

Answer 2

Vielleicht nicht der beste Code in der Welt, aber es ist schnell, weil es vermeidet Schleifen (vorausgesetzt, ich die Frage verstanden):

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

Edit: Am zweiten dachte ich glaube, ich falsch verstanden. Ist das besser?

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 

Denken Sie daran, als Wert zu kopieren und einzufügen, Sie die Daten unter der Annahme, wollen auf diese Weise bleiben. Sonst wird es auch dynamisch!