Question

我正在开发一个简单的子例程来从主工作表中提取值并将这些值移动到其他工作表。当我运行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

Answer 1

您是否已调试以查看其失败的确切位置。例如，当一个已存在时，您不会尝试添加名为Temp的工作表。调试并找到它失败的确切位置。

我

Answer 2

<击> 当我运行该代码时，它会显示：

编译错误：

Sub或Function not defined

~~然后突出显示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上设置一个断点，以便退回到违规行。

VBA子例程声明问题停止excel正确执行VBA

2 个答案: