macros不执行

我有下面的代码。 我想要实现的是macros应该低下国家列。 F列。find一个国家，然后将该国家的所有数据复制并粘贴到新的表格中。 将该国家的选项卡命名为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

编辑 ，修改行：

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

同

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

错字（我必须用正确的forms写成几千次）没有破坏代码，但却是（无意）提到从第1行到最后一个表中的列“A：Q”的范围，而不是在“A”列中的最后一个非空的一个。 如果在不同的“老化的”excel文件之间共享的话，这个范围会非常大，并且可能会破坏代码，在excel 2007之前，表格最大的行数将会增加近65000，达到100多万

---

有两个错误

• Worksheets.Add (ThisWorkbook.Worksheets.Count)

  一定是：

  Worksheets.Add Worksheets(Worksheets.Count)

• .AutoFilter 10, rCountry.Value2

  一定是：

  .AutoFilter 6, rCountry.Value2

因为国家是你的数据库的第六列

此外，我build议你使用：

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

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

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

在意识到CountryList是包含所有数据的表单之后进行编辑 ，并且Sheet1是具有“国家/地区”列表的表单…

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

Answer 2

您正尝试将客户与国家/地区相匹配。 rCl是列A，它是客户列。 因此，例如，您正在F列中search27351637，这将永远不匹配，所以rTest总是没有，这就是为什么你没有看到新的工作表得到创build。

如果您的国家列表位于不同的工作表上，请使用全名，例如

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