用值填充列直到最后一行

Question

我的代码应该从 Excel 文件 TimeSheet 中复制数据。每个文件都包含带有人名的标题和带有日常记录的块。代码循环文件夹中的所有 excel 文件并将记录附加到主文件。代码在这里部分解决了。但是现在我在用人名填写 A 列时遇到问题。

代码应首先用任务填充 NewSht 中的 B 列，然后从归档的 B7 OldSht 中获取值并将其复制到 A 列 NewSht 中的第一个空单元格并填充到 B 列中的最后一行。使用当前代码，我得到 ​​p>

'Range类的自动填充方法失败'

错误。

Sub AllFiles()

Application.EnableCancelKey = xlDisabled

Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb  As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim OldSht As Worksheet
Dim FindRng As Range
Dim target As Range
Dim LastRow As Long

' set master workbook
Set Masterwb = Workbooks("result2.xlsm")

folderPath = "C:\Users\TimeSheets2019\inside" 'contains folder path

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False

Filename = Dir(folderPath & "*.xlsx*")
Do While Filename <> ""
    Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
    Set NewSht = Masterwb.Worksheets("Tabelle1") ' added
    Set OldSht = wb.Worksheets("Manager Form") ' added

    ' get the first empty row in the new sheet
    Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
    Set target = NewSht.Cells(NewSht.Rows.Count, 2).End(xlUp).Offset(1, 0)
LastRow = NewSht.Range("B" & Rows.Count).End(xlUp).Row
    'copy taks list to column B            
    OldSht.Range("B7:B15, B17:B26").Copy
    NewSht.Cells(NewSht.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
' copy person name until last row in coulmn B
    OldSht.Range("B5").AutoFill Destination:=NewSht.Range("A2:A" & LastRow), Type:=xlFillDefault
    wb.Close False

Exit_Loop:
    Set wb = Nothing
    Filename = Dir
Loop
Application.ScreenUpdating = True

End Sub

TimeSheet to copy

Results in Master file

Answer 1

正如 cmets 中已经指出的那样，Range.AutoFill 仅在目标范围包括源范围时才有效。您不能从一张纸自动填充到另一张纸。

我认为您只需要在这里进行简单的价值转移：

NewSht.Range("A2:A" & LastRow).Value = OldSht.Range("B5").Value