Question

我想使用VBA从excel中的列表创建工作表，我有以下代码可以正常工作。但它不会从列表中删除重复项，如果我使用删除重复项，则会抛出错误。 :)。我不想改变原始列。

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

简单方法（但如果你有很多数据，我认为不是最好的）：

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

Answer 2

这段代码怎么样？它将保留原始色谱柱，并在保持范围内移除褶皱。它的资格也更加干净。

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

从范围中删除重复项并用于每个循环

2 个答案: