excel VBA根据表格内容新建工作簿并贴入内容

最新推荐文章于 2025-05-25 12:00:00 发布

野生研究员

最新推荐文章于 2025-05-25 12:00:00 发布

阅读量4.6k

点赞数

CC 4.0 BY-SA版权

文章标签： VBA EXCEL 新建工作簿 excel复制

本文链接：https://blog.youkuaiyun.com/qq_25846269/article/details/99207901

本文通过对比两种VBA代码，展示了如何使用更简洁高效的代码实现相同的功能，即根据Excel表格中的列名创建多个工作簿，并保留原始格式。通过具体实例，文章强调了代码优化的重要性。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

Sub addRe()
    '1.此脚本用于根据sheet1中的第一列从第三行开始的数据新建工作簿并重命名
    '2.复制第一列和对应的列的值
    '3.调整新建工作簿的列宽
    ScreenUpdating = False '关闭屏幕刷新
    Dim sCount As Long     '列数
    Dim sCol As Long       '行数

    Dim rnG1 As Range '第一列区域
    Dim rnG2 As Range '第二列区域
    Dim rn As Range   '第一列的开头
    Dim arr1() '第一列的数组（静态）
    Dim arr2() '第二列的数组（动态）

    Set rn = Sheet1.Cells(2, 1) '读出新工作簿要用的第一列的开头
    Set rnG1 = Sheet1.Range(rn, rn.End(xlDown)) '读出新工作簿要用的第一列的区域
        sCount = Sheet1.Range("A2").CurrentRegion.Columns.Count - 1 '读出行数
        sCol = rnG1.Rows.Count '读行数
        arr1 = rnG1 '第一列
    Dim arrName() '名字数组
    ReDim arrName(sCount - 1) '调整数组大小
    
    For i = 1 To sCount
        
        Set rn = Sheet1.Cells(2, i + 1) '读出新工作簿要用的第二列的开头
        Set rnG2 = Sheet1.Range(rn, rn.End(xlDown)) '读出新工作簿要用的第二列的区域
        arr2 = rnG2 '转换为数组
        Sheet1.Activate
        Sheets.Add after:=ActiveSheet '新建工作簿
        
        ActiveSheet.Name = Sheet1.Cells(2, i + 1) '工作簿重命名
        arrName(i - 1) = ActiveSheet.Name '记录新建工作簿的名称
        ActiveSheet.Range(Cells(2, 1), Cells(sCol, 1)) = arr1 '第一列赋值
        ActiveSheet.Range(Cells(2, 2), Cells(sCol, 2)) = arr2 '第二列赋值
        
        Columns("A:B").EntireColumn.AutoFit '调整选中所有新建的工作簿AB列的列宽
    Next i

    Sheet1.Activate '回到Sheet1工作簿
    ScreenUpdating = True '打开屏幕刷新
End Sub

在我写完上面的代码之后很快就被啪啪打脸了：

下面这个简单高效，结果一样还保留了格式。。。

Sub fz()
    Dim a As Byte
    For a = 2 To Cells(2, Columns.Count).End(xlToLeft).Column
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Name = Worksheets(1).Cells(2, a)
            Worksheets(1).Select
            Worksheets(1).Columns(1).Copy .Range("a1")
            Worksheets(1).Columns(a).Copy .Range("b1")
        End With
    Next a
End Sub

表格内容大概是这样的：


时间	J2-01(JD0280)_位移(mm)	J2-02(JD0267)_位移(mm)	J2-03(JD0282)_位移(mm)	J2-04(JD0275)_位移(mm)
2019-07-30	-0.14	-0.24	-0.2	-0.26
2019-07-29	-0.14	-0.24	-0.2	-0.26
2019-07-28	-0.14	-0.23	-0.19	-0.26
2019-07-27	-0.14	-0.23	-0.19	-0.26
2019-07-26	-0.13	-0.23	-0.19	-0.26
2019-07-25	-0.13	-0.23	-0.18	-0.25
2019-07-24	-0.13	-0.22	-0.18	-0.25
2019-07-23	-0.13	-0.22	-0.18	-0.25
2019-07-22	-0.13	-0.22	-0.17	-0.24
2019-07-21	-0.13	-0.22	-0.17	-0.25
2019-07-20	-0.12	-0.21	-0.16	-0.24
2019-07-19	-0.12	-0.21	-0.15	-0.24
2019-07-18	-0.12	-0.2	-0.14	-0.23
2019-07-17	-0.12	-0.21	-0.16	-0.24
2019-07-16	-0.12	-0.2	-0.14	-0.23
2019-07-15	-0.11	-0.19	-0.12	-0.22
2019-07-14	-0.11	-0.19	-0.11	-0.21
2019-07-13	-0.1	-0.18	-0.11	-0.21
2019-07-12	-0.11	-0.19	-0.12	-0.21
2019-07-11	-0.11	-0.19	-0.12	-0.22
2019-07-10	-0.11	-0.19	-0.11	-0.21
2019-07-09	-0.1	-0.18	-0.1	-0.21
2019-07-08	-0.1	-0.18	-0.1	-0.21
2019-07-07	-0.1	-0.18	-0.1	-0.21
2019-07-06	-0.1	-0.18	-0.1	-0.21

结果是这样的：