我正在尝试自动过滤以删除包含值0的所有行。代码单独工作（它是底部的最后一位），但是当我将它添加到我的更大的宏时，我得到了
运行时错误1004
问题似乎在于：
Set VRange = Range(ActiveSheet.Range("b1"), ActiveSheet.Range("b1").End(xlDown))
但是我无法弄清楚如何改变它以达到我想要的效果（并保持简单，以便我可以将其重复用于其他纸张，而无需多次更改/指定纸张名称）< / p>
任何帮助都会受到赞赏 - 我被困住了。谢谢你们！
Sub Test()
Sheets("Sheet1").Activate
' Add a heading to the “GL” column
Range("C2").Select
ActiveCell.FormulaR1C1 = "GL"
'Create new worksheets for each heading (with heading names)
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("D2:P2")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
'Copies the master sheet values into new worksheet called “Test”
'(that was created with the code above based on the header name in row 2),
' and deletes inapplicable columns
Sheets("Sheet1").Activate
ActiveSheet.UsedRange.Copy
Sheets("Test").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Test").Range("A1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = "Test" _
Or ActiveCell.Value = "GL" Then
ActiveCell.Offset(0, 1).Select
Else
ActiveCell.EntireColumn.Select
Selection.Delete Shift:=xlToLeft
Selection.End(xlUp).Select
End If
Loop
' THIS CODE DOESN'T WORK WITH REST OF MACRO BUT WORKS ON ITS OWN
' Removes 0 values and total row
Sheets("Test").Activate
Dim VRange As Range
Set VRange = Range(ActiveSheet.Range("b1"), ActiveSheet.Range("b1").End(xlDown))
With VRange
.AutoFilter
.AutoFilter field:=1, Criteria1:="0"
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
On Error Resume Next
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
答案 0 :(得分：0)
代码本身（它是底部的最后一位），但是什么时候 我将它添加到我更大的宏中......
这是因为你的更大的宏在＆＃34; standalone＆＃34;之前做了一些事情。后者不知道的代码，因此无法处理
例如
代码行
Sheets("Sheet1").Activate
ActiveSheet.UsedRange.Copy
Sheets("Test").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Test").Range("A1").Select
正在复制＆＃34; Sheet1＆＃34; UsedRange并粘贴到＆＃34;测试＆＃34;从单元格A1开始的工作表
UsedRange的右上角有一些众所周知的（仅供您使用）单元格 Do Until ... Loop循环正在删除＆＃34;测试＆＃34;与从A1
如果没有细胞＆＃34;测试＆＃34;或＆＃34; GL＆＃34;内容然后全部＆＃34;测试＆＃34;相关的工作表（即第1行中没有空单元格）列将被删除！
就上述两个问题而言，Set VRange = Range(ActiveSheet.Range("b1"), ActiveSheet.Range("b1").End(xlDown))可以很好地引用＆＃34;测试＆＃34;表格整空列B！
最后，为了真正帮助您，您应该使用可能的＆＃34; Sheet1＆＃34;来增强您的代码（以及您的帖子）。数据＆＃34;结构＆＃34;处理
并且还考虑放弃所有Select/Activate/Selection/ActiveXXX编码模式，因为它会让您快速失去对代码实际执行内容的控制
尝试帮助您对代码进行可能的重构，您可以考虑以下内容（注释中的解释）：
Sub Test()
Dim xRg As Range
With Sheets("Sheet1") 'reference "Sheet1" sheet
.Range("C2").Value = "GL" ' Add “GL” column heading to referenced sheet "C2" cell
'Create new worksheets for each heading (with heading names)
With .Range("D2:P2") 'reference referenced sheet range "D2:P2"
Select Case True
Case WorksheetFunction.CountA(.Cells) = 0 'if only empty cells in referenced range
MsgBox "no values in " & .Address(False, False)
Exit Sub
Case .Find("test", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False) Is Nothing
If Not IsSheetAlreadyThere("Test") Then
MsgBox "no 'Test' sheet neither in " & .Address(False, False) & " nor already in " & ActiveWorkbook.Name & " workbook"
Exit Sub
Else
Sheets("Test").UsedRange.ClearContents
End If
End Select
For Each xRg In .SpecialCells(xlCellTypeConstants) 'loop through referenced range not empty cells only
If IsSheetAlreadyThere(xRg.Value) Then ' if current cell value matches an existent sheet name
Sheets(xRg.Value).UsedRange.ClearContents ' clear the content of the existent sheet named after current cell value
Else
On Error Resume Next ' handle possible errors due to invalid sheet names
Sheets.Add(after:=Sheets(Sheets.Count)).Name = xRg.Value 'add a new sheet and try naming it after current cell value
If Err.Number = 1004 Then ' if naming new sheet failed
Debug.Print "Name '" & xRg.Value & "' not a valid worksheet name"
Application.DisplayAlerts = False
ActiveSheet.Delete 'deelete new sheet
Application.DisplayAlerts = True
End If
On Error GoTo 0
End If
Next
End With ' stop referencing "Sheet1" sheet rang "D2:P2"
'Copies the master ("Sheet1") sheet values into new worksheet called “Test”
'(that was created with the code above based on the header name in row 2),
' and deletes inapplicable columns
With .UsedRange 'reference referenced sheet (i.e. "Sheet1") "used" range
Sheets("Test").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value ' copy paste its values in "Test" sheet starting from this latter A1 cell
End With
End With ' stop referencing "Sheet1" sheet
With Sheets("Test") ' reference "Test" sheet
If WorksheetFunction.CountA(.Rows(1)) = 0 Then 'if only empty cells in reference sheet (i.e. "Test") row 1
MsgBox "no values in " & .Address(False, False)
Exit Sub
End If
Dim f As Range
Set f = .UsedRange.Cells(1, .UsedRange.Columns.Count + 1) ' set f as a "dummy" cell out of used range
For Each xRg In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)) 'loop through referenced sheet row 1 cells from column 1 rightwards to last not empty one
Select Case xRg.Value ' query curent cell value
Case "Test", "GL" ' if it's a "good" name then do nothing
Case Else ' if it's a "bad" name then add current cell to the ones whose entirecolumn is to be deleted
Set f = Union(f, xRg)
End Select
Next
Set f = Intersect(.UsedRange, f) ' get rid of the "dummy" cell
If Not f Is Nothing Then f.EntireColumn.Delete 'if any found cell with "bad" names then delete their entire column
With .Range("B1", .Range("b1").End(xlDown)) ' <<<< hope that there's actually some data in column "B" !!>>>>
.AutoFilter
.AutoFilter field:=1, Criteria1:="0"
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
With Intersect(.Columns("A"), .UsedRange) 'reference referenced sheet column A cells in used range (avoid considering one million rows)
MsgBox .Address
If WorksheetFunction.CountBlank(.Cells) Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End With ' stop referencing "Test" sheet
End Sub
Function IsSheetAlreadyThere(shtName As String) As Boolean
On Error Resume Next
IsSheetAlreadyThere = Sheets(shtName).Name = shtName
End Function
我正在尝试自动过滤以删除包含该值的所有行 0
除了AutoFilter()方法之外，你可以使用另一个方法：
With Sheets("Test")
With .Range("b1", .Cells(.Rows.Count, 2).End(xlUp)) <<<< hope that there's actually some data in column "B" !!>>>>
.Replace What:=0, Replacement:="", LookAt:=xlWhole
If WorksheetFunction.CountA(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End With