宏不执行

Question

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

Marco 编译得很好但没有任何反应任何帮助将不胜感激。

代码在下面，我也附上了图片

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是Column A，也就是customer Column。因此，例如，您在 F 列中搜索 27351637，它永远不会匹配，因此 rTest 始终为空，这就是为什么您看不到新工作 sheet 正在创建的原因。

如果您的国家/地区列表在不同 sheet 上，请使用全名，例如

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)

打字错误（我一定已经以正确的形式写了数千次）并没有破坏代码，但它（无意中）指的是第 "A:Q" 列中从第 1 行到最后一行的范围sheet 一个，而不是第 "A" 列中的最后一个非空的。相当大的范围......如果在不同的 "aged" excel 文件之间共享，则可能会破坏代码，在 excel 2007 年之前 sheet 最大行跳跃形成近 65000实际超过100万

有两个错误

Worksheets.Add (ThisWorkbook.Worksheets.Count)

必须是：

Worksheets.Add Worksheets(Worksheets.Count)
.AutoFilter 10, rCountry.Value2

必须是：

.AutoFilter 6, rCountry.Value2

因为国家/地区是您数据库的第 6 列

此外，我建议您使用：

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

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

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

编辑意识到 CountryList 是包含所有数据的 sheet 并且 Sheet1 是包含 "Country" 列表的 sheet...

在今天 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

宏不执行

Macro Not Executing

macros

excel

vba

copy-paste