Удалить дубликаты из диапазона и использовать для каждого цикла

Question

Я хочу создать листы из списка в excel с помощью VBA, у меня есть код ниже, который отлично работает. Но он не удаляет дубликаты из списка, и если я использую удаление дубликатов, он выдает ошибку. :). Я не хочу, чтобы исходная колонка изменилась.

Set MyRange = Sheets("YES").Range("A2") 
Set MyRange = Range(MyRange, MyRange.End(xlDown)).RemoveDuplicates 


For Each MyCell In MyRange 




    Sheets.Add After:=Sheets(Sheets.Count) ' creates a new worksheet 
    Sheets(Sheets.Count).Name = UCase(MyCell.Value) ' renames the new worksheet 

    ActiveSheet.Range("A1").Select ' selects current worksheet 
    Cells(1, 1).Font.Bold = True ' changes fornt to bold 
    ActiveCell.Value = ("Column Name") ' enters values into cell 

    ActiveSheet.Range("A2").Select 
    ActiveCell.Value = UCase(MyCell.Value) ' enters column name in cell 

Next MyCell 

благодаря

Answer 1

Как насчет этого кода. Он оставит исходную колонку в тактике и удалит дубликатов в диапазоне удерживания. Это также квалифицировано более чисто.

Dim wsYes as Worksheet 
Set wsYes = Worksheets("YES") 

With wsYes 

    Dim myRange as Range 
    Set myRange = .Range("A2",.Range("A2").End(xlDown)) 

    myRange.Copy .Cells(1,.Columns.Count) 'copy to far right column 
    .Cells(1,.Columns.Count).Resize(myRange.Rows.Count,1).RemoveDuplicates 1, xlNo 

    Set myRange = .Range(.Cells(1,.Columns.Count),.Cells(1,.Columns.Count).End(XlDown)) 

    For Each MyCell In myRange 

     Dim sName as String 
     sName = UCase(MyCell.Value) 

     Dim wsNew as Worksheet 
     Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) ' creates a new worksheet 
     With wsNew 
      .Name = sName 
      .Range("A1").Value = "Column Name" 
      .Range("A1").Font.Bold = True 
      .Range("A2").Value = sName 
     End With 

    Next MyCell 

    myRange.Clear 

End with 

Answer 2

Легкий способ (но не самый лучший, я думаю, что если у вас есть много данных):

Set MyRange = Sheets("YES").Range("A2") 
Set MyRange = Range(MyRange, MyRange.End(xlDown)) 

Dim index1 As Integer 
Dim index2 As Integer 

index1 = 0 
For Each Cell1 In MyRange 

    index1 = index1 + 1 
    index2 = 0 

    For Each Cell2 In MyRange 

     If index2 >= index1 
     Then Exit For 

     If MyCell.Value = Cell2.Value 
     Then Goto NextCell1 

    Next Cell2 

    Sheets.Add After:=Sheets(Sheets.Count) ' creates a new worksheet 
    Sheets(Sheets.Count).Name = UCase(MyCell.Value) ' renames the new worksheet 

    ActiveSheet.Range("A1").Select ' selects current worksheet 
    Cells(1, 1).Font.Bold = True ' changes fornt to bold 
    ActiveCell.Value = ("Column Name") ' enters values into cell 

    ActiveSheet.Range("A2").Select 
    ActiveCell.Value = UCase(MyCell.Value) ' enters column name in cell 

    NextCell1: 
Next Cell1