如何自动填充公式 VBA

How to autofill formulas VBA

提问by user2843579

I am trying ot make a macro that will copy ranges from other reports and put them into one big report. The range copying works fine and does exactly waht it is supposed to. The issue I am having now is how to get the calendar week date (the Monday of the calendar week) using vba. I know of the excel formula to do it but I can't seem to figure out how to implement in vba.

我正在尝试制作一个宏，该宏将从其他报告中复制范围并将它们放入一个大报告中。范围复制工作正常，并且完全符合预期。我现在遇到的问题是如何使用 vba 获取日历周日期（日历周的星期一）。我知道执行此操作的 excel 公式，但我似乎无法弄清楚如何在 vba 中实现。

=DATE(Cell with year in it, 1, -2)-WEEKDAY(DATE(Cell with year in it,1,3))+cell with calendar week number (ie calendar week 13)*7

=DATE(带有年份的单元格, 1, -2)-WEEKDAY(DATE(带有年份的单元格,1,3))+带有日历周数的单元格（即日历周13）*7

What would be the best way to handle getting the date of the Mondayfor each calendar week?

处理每个日历周的星期一日期的最佳方法是什么？

The current autofill method I tried gives me a run-time error '1004: Autofill method of Range class failed.

我尝试的当前自动填充方法给了我一个运行时错误'1004：Range 类的自动填充方法失败。

Sub BeginHere()
Dim wb As Workbook
Dim ws As Worksheet
Dim wbn As Workbook
Dim wsp As Worksheet
Dim year As String
Dim cw As String
Dim fileName As String
Dim formula As Range

Set wb = ThisWorkbook
Set ws = ActiveSheet

'Test Fulmula
Set formula = ws.Range("p1")

'Last Cell in Destination
Dim lastCellD As Range
'First cell in Destination
Dim firstCellD As Range
'Last Cell in Source
Dim lastCellS As Range
'First Cell in Source
Dim firstCellS As Range

Dim fileDir As String
Dim filePath As String

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
End With

'get the last calendar week from the destination report
Set lastCellD = ws.Range("B7:B7").End(xlDown)
'calculate the next calendar week
cw = lastCellD.formula
cw = cw + 1

'Create file path using PQM directory with the cw and years
fileDir = "file directory here"
filePath = "file name here"    
Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range
Dim r6 As Range, r7 As Range, r8 As Range, r9 As Range, cwr As Range
Dim rm As Range, rdw As Range, ry As Range


'If the next report exist continue processing
If Dir(filePath) <> "" Then
    'Open the source workbook
    Set wbn = Workbooks.Open(filePath)
    fileName = wbn.Name
    year = Mid(fileName, 6, 4)
    'Open the source worksheet
    Set wsp = wbn.Worksheets("Problemliste")

    'Get the cell after the last filled cell in the destination sheet for PQM numbers
    Set lastCellD = ws.Cells(Rows.Count, "C").End(xlUp)

    'Get the first and last cell in the source sheet to get the total number of used cells
    Set firstCellS = wsp.Range("A7")
    Set lastCellS = wsp.Cells(Rows.Count, "A").End(xlUp)

    Set r1 = Range(firstCellS, lastCellS)
    r1.Copy lastCellD.Offset(1, 0)

    Set firstCellS = wsp.Range("B7")
    Set lastCellS = wsp.Cells(Rows.Count, "B").End(xlUp)
    Set r2 = Range(firstCellS, lastCellS)
    r2.Copy lastCellD.Offset(1, 1)

    Set firstCellS = wsp.Range("F7")
    Set lastCellS = wsp.Cells(Rows.Count, "F").End(xlUp)
    Set r3 = Range(firstCellS, lastCellS)
    r3.Copy lastCellD.Offset(1, 2)

    Set firstCellS = wsp.Range("H7")
    Set lastCellS = wsp.Cells(Rows.Count, "H").End(xlUp)
    Set r4 = Range(firstCellS, lastCellS)
    r4.Copy lastCellD.Offset(1, 3)

    Set firstCellS = wsp.Range("J7")
    Set lastCellS = wsp.Cells(Rows.Count, "J").End(xlUp)
    Set r5 = Range(firstCellS, lastCellS)
    r5.Copy lastCellD.Offset(1, 4)

    Set firstCellS = wsp.Range("Y7")
    Set lastCellS = wsp.Cells(Rows.Count, "Y").End(xlUp)
    Set r6 = Range(firstCellS, lastCellS)
    r6.Copy lastCellD.Offset(1, 5)

    Set firstCellS = wsp.Range("AK7")
    Set lastCellS = wsp.Cells(Rows.Count, "AK").End(xlUp)
    Set r7 = Range(firstCellS, lastCellS)
    r7.Copy lastCellD.Offset(1, 6)

    Set firstCellS = wsp.Range("BA7")
    Set lastCellS = wsp.Cells(Rows.Count, "BA").End(xlUp)
    Set r8 = Range(firstCellS, lastCellS)
    r8.Copy lastCellD.Offset(1, 7)

    Set firstCellS = wsp.Range("BE7")
    Set lastCellS = wsp.Cells(Rows.Count, "BE").End(xlUp)
    Set r9 = Range(firstCellS, lastCellS)
    r9.Copy lastCellD.Offset(1, 8)

    'Set firstCellD = last cell in column B
    Set firstCellD = ws.Range("B7").End(xlDown)
    'Offset to get the next empty row
    Set firstCellD = firstCellD.Offset(1, 0)
    'Set lastCellD = the bottom cell of column C
    Set lastCellD = ws.Cells(Rows.Count, "C").End(xlUp)
    'Offset by one column to get target column
    Set lastCellD = lastCellD.Offset(0, -1)
    'Create composit range in targer column
    Set rcw = Range(firstCellD, lastCellD)
    rcw.Value = cw

    'put year in destination sheet
    Set firstCellD = firstCellD.Offset(0, 11)
    Set lastCellD = lastCellD.Offset(0, 11)
    Set ry = Range(firstCellD, lastCellD)
    ry.Value = year

    'get calendar week date
    Set firstCellD = firstCellD.Offset(0, -1)
    Set lastCellD = lastCellD.Offset(0, -1)
    Set rdw = Range(firstCellD, lastCellD)
    'Here is where the error occures
    '********************************************************************
    Range("p1").Autofill Destination:=Range(firstCellD, lastCellD), Type:=xlFillDefailt
    '********************************************************************
    Set firstCellD = firstCellD.Offset(0, -1)
    Set lastCellD = lastCellD.Offset(0, -1)
    Set rm = Range(firstCellD, lastCellD)
    'get month from the calendar week date
    'rm.Formula = datepart(month)


wbn.Close

Else
    MsgBox ("No new file")
End If


End Sub

回答by Blackhawk

According to the MSDN, Autofill requires that the source be part of the destination (https://stackoverflow.com/a/1528853/2832561)

根据 MSDN，自动填充要求源是目标的一部分（https://stackoverflow.com/a/1528853/2832561）

Looking back through your code...

回顾你的代码......

Set firstCellD = ws.Range("B7").End(xlDown)
'Offset to get the next empty row
Set firstCellD = firstCellD.Offset(1, 0)
'Set lastCellD = the bottom cell of column C
Set lastCellD = ws.Cells(Rows.Count, "C").End(xlUp)
'Offset by one column to get target column
Set lastCellD = lastCellD.Offset(0, -1)
'Create composit range in targer column
Set rcw = Range(firstCellD, lastCellD)
rcw.Value = cw

After the above, both firstCellDand lastCellDare in column "B".

在上述之后，firstCellD和lastCellD都在“B”列中。

'put year in destination sheet
Set firstCellD = firstCellD.Offset(0, 11)
Set lastCellD = lastCellD.Offset(0, 11)
Set ry = Range(firstCellD, lastCellD)
ry.Value = year

Here, they are offset to column "N".

在这里，它们偏移到“N”列。

'get calendar week date
Set firstCellD = firstCellD.Offset(0, -1)
Set lastCellD = lastCellD.Offset(0, -1)
Set rdw = Range(firstCellD, lastCellD)
'Here is where the error occures
'********************************************************************
Range("p1").Autofill Destination:=Range(firstCellD, lastCellD), Type:=xlFillDefailt
'********************************************************************
Set firstCellD = firstCellD.Offset(0, -1)
Set lastCellD = lastCellD.Offset(0, -1)
Set rm = Range(firstCellD, lastCellD)
'get month from the calendar week date
'rm.Formula = datepart(month)

Right before the error, they are offset again, one column to the left: "M". Because "P1" is not in the range in column "M", the Autofill function fails.

就在错误之前，它们再次偏移，向左一列：“M”。由于“P1”不在“M”列的范围内，自动填充功能失败。

---

---

I suggest instead copying the formula to firstCellD, then using that as the source for the Autofill, assuming that the formula in "P1" uses appropriate relative addressing.

我建议改为将公式复制到firstCellD，然后将其用作自动填充的源，假设“P1”中的公式使用适当的相对寻址。

TL;DR & Response to Comment:

TL; DR & 对评论的回应：

What your code is currently doing is trying to Autofill a formula from "P1" into the range of cells in column "M" as defined by Range(firstCellD, lastCellD). This doesn't work because Autofill requires the source cell(s) of the fill to be part of the destination range, just as if you were to do it manually by dragging the fill handle in the lower right-hand corner of a cell. If the formula in "P1" is truly what should be populated into the specified cells of column "M", you should first copy the formula over to firstCellD, then perform the Autofill from firstCellDto the rest of the range. The two lines of code that would do this are:

您的代码目前正在尝试将公式从“P1”自动填充到由Range(firstCellD, lastCellD). 这不起作用，因为自动填充要求填充的源单元格成为目标范围的一部分，就像您通过拖动单元格右下角的填充手柄手动完成一样。如果“P1”中的公式确实应该填充到“M”列的指定单元格中，则您应该首先将公式复制到firstCellD，然后执行从firstCellD到范围其余部分的自动填充。执行此操作的两行代码是：

Range("P1").Copy firstCellD
firstCellD.Autofill Destination:=Range(firstCellD, lastCellD), Type:=xlFillDefault

Make a backup copy of your Excel doc and give it a try!

制作 Excel 文档的备份副本并尝试一下！

回答by user2843579

Instead of using autofill I just put the formula I needed in another sheet, copied the formula to the clipboard, and used pasteSpecial.

我没有使用自动填充，而是将我需要的公式放在另一个工作表中，将公式复制到剪贴板，然后使用 pasteSpecial。

ws2.Range("L1").Copy
rdw.PasteSpecial (xlPasteAll)