如何一键在同一文件夹生成新的excel表

aumicar

原表需要一键把里面的两个子表生成新的表，并用新表的文件名为A1单元格，请教如何编程。谢谢大神

liulang0808

Sub test()
    pth = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False
    For Each sh In Sheets
        If Len(sh.[a1]) > 0 Then
            sh.Copy
            ActiveSheet.[a1].Value = ""
            ActiveWorkbook.SaveAs pth & sh.[a1] & ".xlsx"
            ActiveWorkbook.Close False
        End If
    Next sh
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。

aumicar

liulang0808 发表于 2023-3-9 18:52
附件内容供参考。。。。。

宏测试可以使用的，谢谢版主。请问如果是导出其中两个子表，比如表1、表2在同一个新的excel工作表呢，名称依然用表1的A1单元格命名

liulang0808

aumicar 发表于 2023-3-9 23:31
宏测试可以使用的，谢谢版主。请问如果是导出其中两个子表，比如表1、表2在同一个新的excel工作表呢，名 ...

不是太明白什么意思
是一个文件中有多张表吗？

aumicar

liulang0808 发表于 2023-3-10 08:05
不是太明白什么意思
是一个文件中有多张表吗？

是的，产生新的表图一变图二，以表1的A1单元格内容命名文件。

liulang0808

Sub test()
    pth = ThisWorkbook.Path & "\"
    Set wb = Nothing
    Application.ScreenUpdating = False
    For Each sh In Sheets
        If Len(sh.[a1]) > 0 Then
            If wb Is Nothing Then
                sh.Copy
                ActiveSheet.[a1].Value = ""
                ActiveSheet.Name = sh.[a1]
                Set wb = ActiveWorkbook
            Else
                sh.Copy after:=wb.Sheets(wb.Sheets.Count)
                ActiveSheet.[a1].Value = ""
                ActiveSheet.Name = sh.[a1]
            End If
        End If
    Next sh
    If Not wb Is Nothing Then
        wb.SaveAs pth & "新生成的文件.xlsx"
        wb.Close False
    End If
    Application.ScreenUpdating = True
End Sub

liulang0808

原表.zip (14.43 KB, 下载次数: 8)

2023-3-10 10:18 上传

点击文件名下载附件

附件内容供参考。。。。

aumicar

liulang0808 发表于 2023-3-10 10:19
附件内容供参考。。。。

是类似6楼这个样式的

liulang0808

看看是否可行吧