0

他のレポートから範囲をコピーして 1 つの大きなレポートに入れるマクロを作成しようとしています。範囲のコピーは正常に機能し、想定どおりに機能します。私が今抱えている問題は、vba を使用してカレンダーの週の日付 (カレンダーの週の月曜日) を取得する方法です。それを行うためのExcelの式は知っていますが、vbaで実装する方法がわかりません。

=DATE(年を含むセル, 1, -2)-WEEKDAY(DATE(年を含むセル,1,3))+カレンダーの週番号を含むセル (つまり、カレンダーの週 13)*7

各暦週の月曜日の日付を取得するための最良の方法は何ですか?

私が試した現在のオートフィル メソッドでは、実行時エラー '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
4

2 に答える 2

0

オートフィルを使用する代わりに、必要な数式を別のシートに配置し、数式をクリップボードにコピーして、pasteSpecial を使用しました。

ws2.Range("L1").Copy
rdw.PasteSpecial (xlPasteAll)
于 2013-10-29T16:53:14.823 に答える