☰

根据条件将行复制/粘贴到新工作表中的宏

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba
根据条件将行复制/粘贴到新工作表中的宏

我有一份姓名和数据列表，标题如下：

Year    Forename    Surname DOB Gender  UPN

数据变量是第 1 列（A）中有 7 个年份（第 1 年 - 第 7 年）

我想运行一个宏

  1. 根据 A 列中孩子所在的年份，将行复制到其自己的工作表中。
  2. 如果可能的话，它应该创建一个新的工作表，例如第 1 年、第 2 年、第 3 年等，其中包含所有 6 列数据中的相关数据。

几天来，我尝试混合和匹配几个宏，但没有成功，并且我不想使用 ifs/lookups，因为它将供管理人员使用，只需单击按钮即可。

提前谢谢了。

答案1

这应该可以完成这项工作：

Sub yearAssign()
    Application.ScreenUpdating = False
    On Error GoTo SheetError
    sheetname = "initial"
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wks1 As Worksheet
    Set wkb = ThisWorkbook
    Set wks = Sheets(sheetname)
    totalsheets = wkb.Worksheets.Count
    For i = 1 To totalsheets
        Set wks1 = wkb.Worksheets(i)
        thename = wks1.Name
        If thename <> sheetname Then
            wks1.Rows.Clear
        End If
    Next i
    totalrows = wks.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To totalrows
        theyear = wks.Cells(i, 1)
        Set wks1 = Sheets(theyear)
            lastrow = wks1.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If lastrow = 2 Then
                wks.Rows(1).Copy Destination:=Sheets(theyear).Range("A1")
            End If
            wks.Rows(i).Copy Destination:=Sheets(theyear).Range("A" & lastrow)
    Next i
    Application.ScreenUpdating = True
    finish = MsgBox("Finished", vbInformation)

SheetError:
    If Err.Number = 9 Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = theyear
        Resume
    End If
End Sub

转到 VBA /Macro，在本工作簿插入一个新模块并将代码粘贴到窗口右侧。

假设数据位于名为最初的”，将该行更改sheetname="initial"为您正在使用的名称。

相关内容