vba 将工作表按字段名筛选生成新表

JK723196

vba 将工作表按字段名筛选生成新表

An374938857

是在原文件里生成多个工作表，还是直接生成多个工作簿文件？

JK723196

An374938857 发表于 2022-3-25 11:00
是在原文件里生成多个工作表，还是直接生成多个工作簿文件？

生成多个工作簿文件

JK723196

An374938857 发表于 2022-3-25 11:00
是在原文件里生成多个工作表，还是直接生成多个工作簿文件？

生成多个工作簿文件

wengjl

Sub 按考核人员生成工作簿()
    ' 2022-3-25
    Application.DisplayAlerts = False
    mypath = ThisWorkbook.Path   
    ' --   
    x2 = 2
    Do While Not (IsEmpty(Sheet2.Cells(x2, 1).Value))
      c_xm = Sheet2.Cells(x2, 1).Value
      Sheet3.Select
      Rows("2:20000").Select
      Selection.Delete Shift:=xlUp    ' 删除已有数据的行，以保证数据的正确
      ' --
      x1 = 2
      Do While Not (IsEmpty(Sheet1.Cells(x1, 5).Value))
        If Sheet1.Cells(x1, 5).Value = c_xm Then
          x3 = 2
          Do While Not (IsEmpty(Sheet3.Cells(x3, 5).Value))
            x3 = x3 + 1
          Loop
          For y = 1 To 22
            Sheet3.Cells(x3, y).Value = Sheet1.Cells(x1, y).Value
          Next y
        End If
        x1 = x1 + 1
      Loop
      ' --
      Sheet3.Select
      Cells.Select
      Selection.Copy
      ' --
      Set wb = Workbooks.Add      
      wb.Worksheets(1).Range("a1").Select  
      ActiveSheet.Paste
      wb.Worksheets(1).Name = c_xm   
      wb.SaveAs ThisWorkbook.Path & "\" & c_xm      
      wb.Close True      
      ' --
      x2 = x2 + 1
    Loop
   
End Sub

我的单位电脑有加密，所以无法上传附件
我把你的附件作了如下处理：
1、增加sheet2，在A1写上姓名，A2、A3、A4分别写上三位考核人的姓名，作为循环处理的依据
2、增加sheet3，将sheet1的标题行复制到sheet3上

然后执行宏即可

wengjl

Sub 按考核人员生成工作簿()
    ' 2022-3-25
    Application.DisplayAlerts = False     '关闭系统的对话框
    mypath = ThisWorkbook.Path         ' 这个工作的路径
    ' --   
    x2 = 2
    Do While Not (IsEmpty(Sheet2.Cells(x2, 1).Value))
      c_xm = Sheet2.Cells(x2, 1).Value
      Sheet3.Select
      Rows("2:20000").Select
      Selection.Delete Shift:=xlUp    ' 删除已有数据的行，以保证数据的正确
      ' --
      x1 = 2
      Do While Not (IsEmpty(Sheet1.Cells(x1, 5).Value))
        If Sheet1.Cells(x1, 5).Value = c_xm Then
          x3 = 2
          Do While Not (IsEmpty(Sheet3.Cells(x3, 5).Value))
            x3 = x3 + 1
          Loop
          For y = 1 To 22
            Sheet3.Cells(x3, y).Value = Sheet1.Cells(x1, y).Value
          Next y
        End If
        x1 = x1 + 1
      Loop
      ' --
      Sheet3.Select
      Cells.Select
      Selection.Copy
      ' --
      Set wb = Workbooks.Add       ' 新建一个工作簿
      wb.Worksheets(1).Range("a1").Select
      ActiveSheet.Paste       ' 粘贴
      wb.Worksheets(1).Name = c_xm                  ' 命名工作表名称
      wb.SaveAs ThisWorkbook.Path & "\" & c_xm       ' 保存
      wb.Close True                               ' 关闭工作簿
      ' --
      x2 = x2 + 1
    Loop
   
End Sub

small_small

    试  试

JK723196

非常感谢!!

JK723196

wengjl 发表于 2022-3-25 15:51
Sub 按考核人员生成工作簿()
    ' 2022-3-25
    Application.DisplayAlerts = False     '关闭系统的对 ...

非常感谢!!

JK723196

wengjl 发表于 2022-3-25 15:47
Sub 按考核人员生成工作簿()
    ' 2022-3-25
    Application.DisplayAlerts = False

非常感谢!!