Question

我有此产品列表，并且我想：

根据C列上的值创建新工作表，如果已经存在与单元格值同名的工作表，则不要创建新工作表。（例如，在我的示例中，“摘要”已为第2行创建，因此无需为第3行再次创建）
将整行剪切到匹配的工作表中。
确保将第一行复制到所有工作表上。

This is a before picture

After Pic #1: new sheets created, nothing left on first sheet except the 1st row

After Pic #2: the sheet contains 2 products because there were 2 "Abstract" in column C

After Pic #3: the sheet contain 1 product because there was 1 "Plain" in column C

After Pic #4: the sheet contain 1 product because there was 1 "Shiny" in column C

Answer 1

这将完成工作。

我将第一张工作表命名为“工作表”。
代码是动态的，因此您需要自己输入2个值：

应该创建新工作表的范围/名称：

Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list

以及要复制到新工作表的列数（它比整行都要动态）

lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet

VBA代码：

Sub AddNewSheetFromRange2()
Dim c As Range
Dim ws As Worksheet
Dim myrange As Range
Dim lastcol As Integer
Dim lrow As Integer
Dim lrow_newsheet As Integer
Dim i As Integer

Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list
lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet

lrow = Cells(Rows.Count, 3).End(xlUp).Row 'find last row for range that should create the new worksheet list

i = 1 'Set first index loop to 1

For Each c In myrange.Cells
i = i + 1 'Create index for each loop, used to know which row that should be copied
    'Debug.Print c 'Print which Sheet Name that will be examine
    Set ws = Nothing
    On Error Resume Next
    Set ws = Worksheets(c.Value)
    On Error GoTo 0
        If ws Is Nothing Then

        With ThisWorkbook
            Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Add new sheet after (not before)
            ws.Name = c.Value 'Rename the new sheet
        End With


        Dim WorksheetSheet As Worksheet 'Declare variable for Main worksheet
        Set WorksheetSheet = ActiveWorkbook.Worksheets("Worksheet") 'Name the Main sheet
        Dim NewSheet As Worksheet 'Declare variable for new worksheet
        Set NewSheet = ActiveWorkbook.Worksheets(ws.Name) 'Make all new worksheets dynamic by taking name from range

        'Copy Headers from Main sheet to New Worksheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(1, 1), Cells(1, 3)).Copy
        Worksheets(ws.Name).Activate
        ThisWorkbook.Worksheets(ws.Name).Range(Cells(1, 1), Cells(1, 3)).PasteSpecial

        'Copy row from Main sheet to New Worksheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
        Worksheets(ws.Name).Activate
        lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
        ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial

        'Clear row in Main sheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear

        Else

        'If worksheet already exists, then
        'Copy row from Main sheet to existing worksheet with exactly the same name
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
        Worksheets(ws.Name).Activate
        lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
        ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial

        'Clear row in Main sheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear

        End If
Next c
End Sub

在excel中可视化代码，您必须从以下内容开始：

，最终输出将是这个（单个工作表中的四行，如果名称已经存在，它将添加到已经存在的工作表中）

Excel：基于列中的值将行剪切到新工作表

1 个答案: