Excel VBA自动筛选器将复制粘贴到新命名表格中

Question

我有一列（B），其中包含许多不同的唯一值，我需要对其进行过滤，将粘贴复制到为这些值命名的新工作表中。我已经在另一个工作簿中成功完成了这个任务，但是我在这种情况下无法正常工作，我想这是因为列中有几个空白。即使当我用假人填充空格时，由于运行时错误1004，它也会在同一个地方（第6行）中断：“提取范围有缺失或无效的字段名称”。这里是我对该部分的代码：

Dim c As Range 
Dim rng As Range 
Dim LR As Long 

    LR = Cells(Rows.Count, "R").End(xlUp).Row 
    Set rng = Range("A1:BF" & LR) 

    Range("B1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BF1"), Unique:=True 

    For Each c In Range([BF2], Cells(Rows.Count, "BF").End(xlUp)) 
     With rng 
      .AutoFilter 
      .AutoFilter Field:=2, Criteria1:=c.Value 
      .SpecialCells(xlCellTypeVisible).Copy 
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value 
      ActiveSheet.Paste 
     End With 
    Next c 

任何想法如何解决这个问题？参考文献BF是包含数据的最后一列，并且行数是可变的，因为这是每日报告。

谢谢！

Answer 1

我认为丹的线索是必须去的：你必须确保单元格“BF1”或者是空白的或者填充与单元格“B1”相同的值。

一种方法可能是在.Autofilter语句之前删除单元格“BF1”内容。

最后还必须注意“B”列中的空白单元格，因为他们会要求输入空白表格名称，这会导致错误。

所以你可以尝试像如下

Option Explicit 

Sub main() 

Dim c As Range 
Dim rng As Range 
Dim LR As Long 

    LR = Cells(Rows.Count, "R").End(xlUp).row 
    Set rng = Range("A1:BF" & LR) 

    Range("BF1").ClearContents '<== ensure possible "BF1" cell content wouldn't match "B1" cell value 

    Range("B1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BF1"), Unique:=True 

    For Each c In Range([BF2], Cells(Rows.Count, "BF").End(xlUp)) 
     With rng 
      .AutoFilter 
      .AutoFilter Field:=2, Criteria1:=c.value 
      .SpecialCells(xlCellTypeVisible).Copy 
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = IIf(c.value = "", "Blank Key", c.value) '<== handle "blank" Key 
      ActiveSheet.Paste 
     End With 
    Next c 
End Sub