用值填充列直到最后一行

Question

我的代碼應從Excel文件TimeSheet復制數據。 每個文件都包含帶有人名的標題，並帶有每日記錄的塊。 代碼循環了文件夾中的所有excel文件，並將記錄追加到主文件。 代碼在這里已部分解決。 但是現在我在用人員名稱填充列A時遇到了問題。

代碼應該首先用任務填充NewSht中的B列，然后從提交的B7 OldSht中獲取值，然后將其復制到NewSht列中的第一個空單元格，並填充直到B列中的最后一行。使用當前代碼，我得到

“ 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

主文件中的結果

Answer 1

如注釋中已經指出的那樣， Range.AutoFill僅在目標范圍包括源范圍時才起作用。 您無法從一張紙自動填充到另一張紙。

我認為您只需要在這里進行簡單的價值轉移：

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