按需拆表

queenie_jing

需求如图，感谢老师。

ykcbf1100

queenie_jing 发表于 2023-2-6 16:44
这里报错标黄了

运行时错误1004，应用程序定义或对象定义错误

你说的那个错误提示是在m=0时会出现。我重新更新了代码。
你再试下。

3190496160

这个帖子的拆分工具完全能够解决你的问题，下载就能用
【新提醒】拆分工具之六-Excel VBA程序开发-ExcelHome技术论坛 - https://club.excelhome.net/forum ... amp;_dsign=b63a686d

ykcbf1100

参与一下。

shongshon22

积极参与学习下，不知道有没有达到你要的效果。
Sub 拆分()
Dim arr, brr(), a, b, c, d, e, f, g
Dim sh As Worksheet
Dim wk As Workbook
a = Worksheets("人员概况").Range("b1").Value
b = Worksheets("人员概况").Range("b2").Value
Application.DisplayAlerts = False
Set wk = Workbooks.Add
For Each sh In ThisWorkbook.Sheets
    If sh.Name <> "人员概况" Then
    c = c + 1
    g = 0
    wk.Sheets(c).Name = sh.Name
       With wk.Sheets(c)
            .Columns("h:h").NumberFormatLocal = "yyyy/m/d"
            .Columns("A:A").ColumnWidth = 6
            .Columns("b:b").ColumnWidth = 10.5
            .Columns("c:c").ColumnWidth = 19
            .Columns("d:d").ColumnWidth = 26
            .Columns("e:e").ColumnWidth = 30
            .Columns("f:f").ColumnWidth = 25
            .Columns("g:g").ColumnWidth = 9
            .Columns("h:h").ColumnWidth = 13
       End With
    arr = sh.Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        For d = 1 To UBound(arr, 2)
        wk.Worksheets(c).Cells(1, d) = arr(1, d)
            If arr(1, d) = a Then e = d
        Next
    For f = 1 To UBound(arr, 1)
        If arr(f, e) = b Then
        g = g + 1
            For d = 1 To UBound(arr, 2)
                brr(g, d) = arr(f, d)
            Next
        End If
    Next
    wk.Sheets(c).Range("a2").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
   
    End If
Next
Erase arr: Erase brr
wk.SaveAs ThisWorkbook.Path & "\" & b & ".xlsx"
wk.Close
Application.DisplayAlerts = True
End Sub

queenie_jing

ykcbf1100 发表于 2022-11-8 16:17
参与一下。

老师，请问一下，如果我需要拆的每张表都有60列，应该怎么改哪个参数呀？不会VBA，瞎琢磨半天一直失败

ykcbf1100

queenie_jing 发表于 2023-2-6 15:15
老师，请问一下，如果我需要拆的每张表都有60列，应该怎么改哪个参数呀？不会VBA，瞎琢磨半天一直失败

应该不用改啊。
但是，如果拆分后列数有变化的话，需要修改brr数组第二个参数。

queenie_jing

ykcbf1100 发表于 2023-2-6 16:13
应该不用改啊。
但是，如果拆分后列数有变化的话，需要修改brr数组第二个参数。

您的解答已经完全匹配我的需求了，只是我的初始文件是8列，但是用您的，点拆分后，只拆出前6列数据来，【人员状态】和【入职日期】均为空值，我再看下，谢谢了

ykcbf1100

queenie_jing 发表于 2023-2-6 16:20
您的解答已经完全匹配我的需求了，只是我的初始文件是8列，但是用您的，点拆分后，只拆出前6列数据来，【 ...

你再试一下。

queenie_jing

ykcbf1100 发表于 2023-2-6 16:38
你再试一下。

这里报错标黄了

运行时错误1004，应用程序定义或对象定义错误

sht.[a2].Resize(m, 8) = brr

ykcbf1100

queenie_jing 发表于 2023-2-6 16:44
这里报错标黄了

运行时错误1004，应用程序定义或对象定义错误

明天我再看看，那里出问题了。