Macro Not Executing

Question

У меня есть код ниже. То, что я пытаюсь достичь, - это макрос, который должен смотреть вниз по столбцу страны. Колонка F. Найдите страну, затем скопируйте и вставьте все данные для этой страны на новый лист. назовите вкладку этой страной и сделайте это снова для следующей страны в колонке 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) 

опечатка (Должно быть, я написал тысячи раз в правильной форме) не сломать код, но он (непреднамеренно) ссылался на диапазон в столбцах «A: Q» от строки 1 до последнего листа один, а не последний не пустой в столбце «A». Довольно большой диапазон ...и потенциально поломать код, если совместно по-разному «в возрасте» Excel-файлов, стоя на лист максимальной строки прыгать формы почти 65 тысяч до Excel 2007, чтобы фактические более 1 млн

---

есть две ошибки

• Worksheets.Add (ThisWorkbook.Worksheets.Count)

  должны быть:

  Worksheets.Add Worksheets(Worksheets.Count)

• .AutoFilter 10, rCountry.Value2

  должны быть:

  .AutoFilter 6, rCountry.Value2

, поскольку страна является шестой столбец базы данных

Кроме того, я предлагаю вам использовать:

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

иметь последующий For Each rCountry In rCL цикл работает только на соответствующих (заполняется с текстовым значением) клеток

Наконец, вы можете попробовать этот переработан код:

отредактированный после понимая, что CountryList является лист со всеми данных и Лист1 является лист со списком "Country" ...

отредактирован 2 после уточнений сегодня Op в

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, который является колонкой клиента. Например, вы ищете 27351637 в столбце F, который никогда не будет соответствовать, поэтому rTest всегда ничего, поэтому вы не видите новые рабочие листы, которые создаются.

Если ваш список стран находится на другом листе, используйте полное имя, например.

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