VBA实现工作簿合并、重命名、创建文件夹，分类等整体功能

tim159143

1.对示例中的三个工作簿进行汇总。2.以班级为字段创建文件夹。（这里要考虑是否重复创建）

3.三个工作簿以班级字段进行重命名，并放入对应的文件夹

4.将合并工作簿中图表以“班级”进行拆分三个图表及命名，然后导出对应班级的文件夹

tim159143

自己顶一下。麻烦老师帮帮忙

tim159143

再顶一下

tim159143

是我这个太简单了吗？

tim159143

Sub 按钮1_Click()

    Application.ScreenUpdating = False
    Dim Fld, F
    Dim newname, pa, newpath As String   '要汇总的文件所在的目录及名称
    Dim arr As Variant         '用来存储各文件中的数据
    Dim mrow As Long       '用来存储各工作表中需要汇总的数据行数
    Dim c As Range   '汇总表中A列的第一空单元格
    pa = ThisWorkbook.path
    Set Fld = CreateObject("Scripting.FileSystemObject").GetFolder(pa)
    For Each F In Fld.Files
        If F.Name Like "*.xlsx" Then
        Workbooks.Open pa & "\" & F.Name   '打开指定的工作簿
        newname = [a2]
''''''''''''''''''''''''''''复制合并'''''''''''''''''''''''''''''''''''''''''''''''''''
                                                                        '确定要汇总的数据行数
        mrow = ActiveWorkbook.Worksheets(1).UsedRange.Rows.Count - 1
                                                                        '将要汇总的数据存储到变量中
        arr = ActiveWorkbook.Worksheets(1).Range("A2").Resize(mrow, 5).Value
                                                                        '获得汇总表中A列的第一个非空单元格
        Set c = ThisWorkbook.Worksheets(1).Range("A1048576").End(xlUp).Offset(1, 0)
                                                                        '将数组中数据写入汇总表
        c.Resize(mrow, 5) = arr
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''创建文件夹'''''''''''''''''''''''''''''''''''''''''''''''''
            If Dir(pa & "\" & newname, vbDirectory) = "" Then '判断是否存在同名文件夹
                MkDir pa & "\" & newname
            End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''另存重命令工作簿'''''''''''''''''''''''''''''''''''''''''''''''''
        mypath = pa & "\" & newname
        ActiveWorkbook.SaveAs mypath & "\" & newname & ".xlsx"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ActiveWorkbook.Close False
        End If
    Next
    Application.ScreenUpdating = True
   
End Sub

tim159143

自力更生，希望能帮助有需要的人

yzesky