1

Office 2003 でこれと同様のコードを使用していましたが、最近 Office 2010 にアップグレードしたところ、コードが機能しなくなりました。コードをステップ実行していて、nStart と nEnd で指定された行をコードが削除しようとするとエラーになります。実行時エラー 1004 が表示されます。フォーラムを検索しましたが、解決策が見つかりません。問題は、コードの最後の数行にあります。

このコードは、大規模なデータ セットからデータをコピーし、組織内の各部門ごとに個別のスプレッドシートに分割するように設計されています。最初のグループがコピーされると、データはマスター シートから削除され、空のセルに到達するまでプロセスが最初からやり直されます。

問題を修正するための試みをいくつか残しましたが、近づいた場合に備えてそれらをコメントに変えました.

どんな助けでも大歓迎です。

Option Explicit
Sub Appraisal_Split()

Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO1 As Worksheet
Dim wsO2 As Worksheet
Dim nRow As Long
Dim nStart As Long, nEnd As Long
Dim Dir As String

'Stop screen from flickering
Application.ScreenUpdating = False

'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Source/Input Sheet
Set wsI = wbI.Sheets("Individual Data")

' Define what directorate to search for.

Do While Cells(2, 1).Value <> ""
Dir = ActiveSheet.Cells(2, "A").Value

' Find where Directorate data starts.
For nRow = 1 To 10000
If Range("A" & nRow).Value = Dir Then
nStart = nRow
Exit For
End If
Next nRow

' Find where the Directorate data ends.
For nRow = nStart To 10000
If Range("A" & nRow).Value <> Dir Then
nEnd = nRow
Exit For
End If
Next nRow
nEnd = nEnd - 1

'~~> Destination/Output Workbook
Workbooks.Open ("G:\Workforce\Reports\Weekly & Monthly & Quarterly Reports\Appraisal  Reports\Appraisal Macro\Department Template.xlsx")

Set wbO = Workbooks("Department Template.xlsx")

With wbO
    '~~> Set the relevant sheet to where you want to paste
    Set wsO1 = wbO.Sheets("Data")

    '~~>. Save the file
    .SaveAs Filename:="G:\Workforce\Reports\Weekly & Monthly & Quarterly Reports\Appraisal Reports\Appraisal Macro\Temp" & "\" & Dir

    '~~> Copy the range
    wsI.Range("A" & nStart & ":I" & nEnd).Copy

    '~~> Paste it data to Cell A1 of new workbook.
    wsO1.Range("A2").PasteSpecial xlPasteFormats
    wsO1.Range("A2").PasteSpecial xlPasteValues
    wsO1.Range("A2").AutoFilter

    ' Copy the column width for the first 9 columns
        Dim i As Integer
            For i = 1 To 9
            wsO1.Columns(i).ColumnWidth = wsI.Columns(i).ColumnWidth
        Next i

    ' Update Summary Pivot Table
        Set wsO2 = wbO.Sheets("Summary")
        wsO2.PivotTables("PivotTable1").RefreshTable

    '~~> Summary Formulas
        wsO2.Range("F4:J4").Select

        Dim LR As Long

        LR = Range("A" & Rows.Count).End(xlUp).Row
        Range("F4:J4").AutoFill Destination:=Range("F4:J" & LR)

        Columns("B:F").EntireColumn.Hidden = True
        Rows("2:3").EntireRow.Hidden = True

    ' Set workbook protection, save and close.
    wsO1.Protect Password:="workforce1", DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFiltering:=True
    wsO1.EnableSelection = xlNoRestrictions
    wsO2.Protect Password:="workforce1", DrawingObjects:=False, Contents:=True,     Scenarios:=True, AllowFiltering:=True
    wsO2.EnableSelection = xlNoRestrictions
    wbO.Close savechanges:=True
End With

**' Delete directorate data from input file
wsI.Rows(nStart, nEnd).Delete
   ' .Rows(nStart & ":" & nEnd).EntireRow.Delete Shift:=xlUp
   ' .Range(nStart, nEnd).EntireRow.Delete**


' Workbooks("Trust Template with Macro.xls").Activate
Loop

End Sub
4

2 に答える 2

1

nStart と nEnd が有効であると仮定します。

wsI.Range(nStart & ":" & nEnd).Delete
于 2013-10-30T17:08:55.280 に答える
0

削除する範囲の形式が正しくありません。Intellisense ヘルプは、問題を確認するのに役立つ場合があります。ただし、行全体を削除するか、データが配置されている領域のみを削除するかに応じて、次のいずれかのバリエーションを試してください。

With wsI
   .Range(.Cells(nStart, 1), .Cells(nEnd, 1)).EntireRow.Delete
End With

また

With wsI
    .Range(.Cells(nStart, "A"), .Cells(nEnd, "C")).Delete shift:=xlUp
End With
于 2013-10-30T17:12:30.313 に答える