vba实现工作表拆分多个工作薄

一、源表展示:

watermark,type_d3F5LXplbmhlaQ,shadow_50,text_Q1NETiBA5ZWK5Lic5LicXw==,size_20,color_FFFFFF,t_70,g_se,x_16

 二、代码部分:

Sub text()
    Dim WK As Workbook
    Dim sh As Worksheet
    Dim a As Integer
    For Each sh In ThisWorkbook.Worksheets
        Set WK = Workbooks.Add
        i = i + 1
        Workbooks(1).Sheets(i).Copy Workbooks(2).Sheets(1)
        WK.SaveAs ThisWorkbook.Path & sh.Name & ".xlsx"
        WK.Close
        Set WK = Nothing
    Next
End Sub

三、结果呈现:

watermark,type_d3F5LXplbmhlaQ,shadow_50,text_Q1NETiBA5ZWK5Lic5LicXw==,size_20,color_FFFFFF,t_70,g_se,x_16

  • 2
    点赞
  • 16
    收藏
    觉得还不错? 一键收藏
  • 打赏
    打赏
  • 1
    评论
假设你有一个名为“原始数据”的工作,其中包含所有员工的姓名和其他详细信息。现在你想要根据员工姓名将数据拆分不同工作,每个工作包含同一姓氏的所有员工信息。以下是一个简单的VBA代码实现这一操作: ```vb Sub SplitDataByLastName() Dim ws As Worksheet Dim lr As Long, i As Long Dim lastName As String Set ws = ThisWorkbook.Worksheets("原始数据") '原始数据工作名称 lr = ws.Cells(Rows.Count, 1).End(xlUp).Row '获取最后一行 For i = 2 To lr '从第二行开始循环 lastName = Split(ws.Cells(i, 1).Value, " ")(1) '获取姓氏 If Not WorksheetExists(lastName) Then '判断工作是否存在,不存在则建一个工作 Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = lastName ws.Rows(1).Copy Destination:=ActiveSheet.Range("A1") '复制第一行标题到建的工作 End If ws.Rows(i).Copy Destination:=Worksheets(lastName).Range("A" & Rows.Count).End(xlUp).Offset(1) '将该行数据复制到对应的工作的最后一行 Next i End Sub Function WorksheetExists(shtName As String) As Boolean '判断工作是否存在 WorksheetExists = False On Error Resume Next WorksheetExists = (Worksheets(shtName).Name <> "") On Error GoTo 0 End Function ``` 这段代码将逐一遍历原始数据工作中的每一行,获取员工的姓氏,并将该行数据复制到以姓氏为名称的工作中。如果该姓氏的工作不存在,则会创建一个工作并将标题行复制到该工作。最后,你将在工作簿中看到多个工作,每个工作包含同一姓氏的所有员工信息。
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

啊东东_

你的鼓励将是我创作的最大动力

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付:¥1
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值