宏未执行

Question

我有以下代码。我想要实现的是宏应该向下看国家专栏。列F.找到一个国家/地区，然后将该国家/地区的所有数据复制并粘贴到新工作表中。将该选项卡命名为该国家/地区，然后再次为F列中的下一个国家/地区执行此操作

马可编辑得很好，但没有任何反应可以得到任何帮助。

代码如下，我还附上了图片

Option Explicit

Sub Filter()

Dim wsCL As Worksheet
Set wsCL = Worksheets("CountryList")

Dim rCL As Range, rCountry As Range
Set rCL = wsCL.Range("A1:A201")

Dim ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")

Dim lRow As Long
lRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

For Each rCountry In rCL

    'check if country exists
    Dim rTest As Range
    Set rTest = ws1.Range("F1:F" & lRow).Find(rCountry.Value2, lookat:=xlWhole)

    If Not rTest Is Nothing Then 'if country is found create sheet and copy data

        Dim wsNew As Worksheet
        Worksheets.Add (ThisWorkbook.Worksheets.Count)
        Set wsNew = ActiveSheet
        wsNew.Name = rCountry.Value2
        ws1.Range("A1:Q1").Copy wsNew.Range("A1") 'place header row

        With ws1.Range("A1:Q" & lRow)
            .AutoFilter 10, rCountry.Value2
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("B1") 'copy data for country under header
            .AutoFilter
        End With

    End If

Next

End Sub

Answer 1

您正在尝试将客户与国家/地区相匹配。 rCl是A列，即客户列。例如，您在F列中搜索27351637，它永远不会匹配，因此rTest始终没有任何内容，这就是您不会看到新工作表被创建的原因。

如果您的国家/地区列表位于其他工作表上，请使用全名，例如：

Set rCL = worksheets("Sheet1").Range("A1:A201")

Answer 2

已修改，修改行：

With .Range("A1:Q" & .Cells(.Rows.Count, 1))

与

With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) 

错字（我必须以正确的形式写了数千次）并没有破坏代码但是（无意中）指的是列中的范围＆＃34; A：Q＆＃34;从第1行到最后一张第1页，而不是列＃34; A＆＃34;中的最后一个非空的。相当大的范围......并且如果在不同的＆＃34;年龄和＃34;之间共享，可能会破坏代码。 excel文件，站在工作表最大行跳转形式，在excel 2007之前将近65,000个实际超过100万

有两个错误

• Worksheets.Add (ThisWorkbook.Worksheets.Count)

  必须是：

  Worksheets.Add Worksheets(Worksheets.Count)

• .AutoFilter 10, rCountry.Value2

  必须是：

  .AutoFilter 6, rCountry.Value2

因为Country是数据库的第6列

此外，我建议您使用：

Set rCL = wsCL.Range("A1:A201").SpecialCells(xlCellTypeConstants, xlTextValues)

让后续For Each rCountry In rCL循环仅对相关（填充文本值）单元格

进行操作

最后，您可能想尝试这个重构的代码：

在认识到CountryList是包含所有数据的工作表并且Sheet1是具有＆＃34; Country＆＃34;的工作表之后，

编辑列表...

在今天的OP澄清之后

编辑了2

Option Explicit

Sub Filter()
    Dim rCountry As Range, helpCol As Range

    With Worksheets("CountryList") '<--| refer to data worksheet
        With .UsedRange
            Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
        End With

        With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A"
            .Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 6th column of the referenced range and store its unique values in "helper" column
            Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
            For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
                .AutoFilter 6, rCountry.Value2 '<--| filter data on country field (6th column) with current unique country name
                If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
                    Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet
                    ActiveSheet.name = rCountry.Value2  '<--... rename it
                    .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
                End If
            Next
        End With
        .AutoFilterMode = False '<--| remove autofilter and show all rows back
    End With
    helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)        
End Sub