Excel VBA自动筛选复制粘贴到新的命名图纸

我有一个列（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是包含数据的最后一列，行数是可变的，因为这是每日报告

---

谢谢

我认为Dan的线索是：必须确保单元格“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

选项显式
副标题（）
调光范围
变暗rng As范围
变暗LR为长
LR=单元格（Rows.Count，“R”）。结束（xlUp）。行
设置rng=范围（“A1:BF”和LR）
范围（“BF1”）.ClearContents“您的
CopyToRange
与数据范围的标题是否相同？是的，我想是的，但我不太清楚这里发生了什么。它仍然每次在同一个地方断裂。工作得很好！非常感谢你的帮助。