1

プライマリ ワークシートから値を取得し、それらの値を追加のシートに移動する単純なサブルーチンに取り組んでいます。VBA マクロを実行すると、サブルーチン宣言を通過することはありません。提案をいただければ幸いです。

Option Explicit
Sub Macro2()
Dim rCell As Range, ws As Worksheet
Application.DisplayAlerts = False

With Sheets("Sheet1")
Sheets.Add().Name = "Temp"
.Range("D2", .Range("D" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy,         CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
For Each rCell In Sheets("Temp").Range("D2", Sheets("Temp").Range("B" & Rows.Count).End(xlUp))
    If Not IsEmpty(rCell) Then
        .Range("D2").AutoFilter field:=3, Criteria1:=rCell
        If SheetExists(rCell.Text) Then
            Set ws = Sheets(rCell.Text)
        Else
            Set ws = Worksheet.Add(After:=Worksheets(Worksheets.Count - 1))
            ws.Name = rCell
        End If
        With .AutoFilter.Range
            .Offset(1).Resize(.Rows.Count - 1).Copy ws.Range("A" & Rows.Count).End(xlUp)(2)
        End With
    End If
Next rCell
Sheets("Temp").Delete
.AutoFilterMode = False
End With

Application.DisplayAlerts = True

End Sub

追加機能

 Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
 Dim sht As Worksheet

 If wb Is Nothing Then Set wb = ThisWorkbook
 On Error Resume Next
 Set sht = wb.Sheets(shtName)
 On Error GoTo 0
 SheetExists = Not sht Is Nothing
 End Function

新しいエラー

extract range has a illegal or missing field name

@

.Range("D2", .Range("D"&Rows.Count).End(xlDown)).AdvancedFilter  Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
4

2 に答える 2

0

どこで失敗するかを正確に確認するためにデバッグしましたか。たとえば、Tempというシートがすでに存在する場合、そのシートを追加しようとはしていません。デバッグして、失敗した場所を正確に見つけます。

私

于 2012-10-17T19:33:49.943 に答える
0

そのコードを実行すると、次のように表示されます。

コンパイル エラー:

サブまたは関数が定義されていません

次に、関数を強調表示しSheetExistsます。SheetExistフォームに含めるのを忘れた関数か、例に含まれていないカスタム関数です 。

編集:うわー、ここで多くのことが起こっています。

その後コードをステップ実行すると、実行時 1004 エラー (「アプリケーション定義またはオブジェクト定義のエラー」) も発生します。

.Range("D2", .Range("D" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True

それを次のように変更してみてください。

.Range("D2", .Range("D" & Rows.Count).End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True

そこから、これを変更します。

Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count - 1))
ws.Name = rCell

これに：

Worksheets.Add(After:=Worksheets(Worksheets.Count - 1)).Name = rCell

ただし、そこからは、With .AutoFilter.Range意図しない限り、何をしているのかわかりませんWith Sheets("Sheet1").AutoFilter.Range。

デバッグの観点からOn Error Goto ErrRoutineは、コードの先頭に追加してから、ルーチンの最後にこれを追加する必要があります。

    Exit Sub

ErrRoutine:

    MsgBox Err.Description
    Resume

そして、ブレークポイントを設定しMsgBox Err.Descriptionて、問題のある行に戻ります。

于 2012-10-17T19:36:49.960 に答える