如何修复此VBA Excel代码,我找不到问题所在

时间:2019-05-30 09:01:33

标签: excel vba macros

问题出现在下面的代码行中。我正在尝试使用自动过滤器来过滤我们的唯一值,然后将这些唯一值复制并粘贴到新的Excel标签中。但是,宏在下面的代码行处停止工作。

Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, 
CopyToRange:=Range("CA1"), Unique:=True

Private Sub CommandButton3_Click()

Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "data"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:AY" & last)
'set last column

Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy,     
CopyToRange:=Range("CA1"), Unique:=True

For Each x In Range([CA2], Cells(Rows.Count, "CA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=1, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
ActiveSheet.Range("A1").Select
ActiveSheet.Columns("A:A").Select
Selection.ColumnWidth = 15

End With
Next x

' Turn off filter
Sheets(sht).AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

代码停在帖子中突出显示的行。

2 个答案:

答案 0 :(得分:1)

我认为:

  1. 您在代码末尾缺少End Sub
  2. CopyToRange:=Range("CA1"),,您没有提及工作表名称只是范围。

答案 1 :(得分:0)

正在工作!

Private Sub CommandButton3_Click()

Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "data"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:AY" & last)
'set last column

Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("CA1"), Unique:=True


End Sub