使用VBA将Excel工做表分割成多个文件

##问题描述 有一个表格，具体数据以下图所示。这里须要按城市（即B列数据）对表格进行拆分，拆分出多个以城市名称命名的xlsx文件，每一个xlsx文件都只包含当前城市的数据。

##相关资料 以前没有接触过Excel相关的编程，也没有学习过VB语言，彻底是摸着石头过河。在这里把期间使用过的一些资料罗列下，方便之后再次用到的时候，能够快速再捡起来。

1. Excel 2007 VBA Macro Programming 这个是英文版的电子书，当初在皮皮书屋(皮皮书屋是好东西，你懂的)上随便找的，作为我VBA的入门书籍。主要从这本书里学习了VBA的对象模型，几个经常使用的对象，Application、Workbook、Worksheet、Range。这本书有个好的地方就是在书的后面有个索引，能够快速地查看本身想了解的内容。这本书也有个大的缺陷，就是内容讲得还不够详细具体，每每找到了本身想了解的内容，想深刻了解下各类操做，结果发现它讲完了。

2. 在线教程 这是个很是好的网站，里面包含了不少简单的例子及代码。当想要实现某个简单地操做的时候，能够先到这里来找找看有没有相应的实例。有一点搞不明白的就是，明明是中文网站，怎么贴的图片里的Excel都是日文的(好吧，不深究了)。对于新手来讲很是有用，推荐之。

3. Excel函数在线查询 最权威的Excel函数查询网站，好吧，其实就是微软的MSDN啦。虽说MSDN的文档有时候的确搞不清楚它在讲什么，可是它仍是最详细的。 ##代码 好吧，不废话了，直接上代码。

   <!-- lang: vb -->

   Sub XXX_Click()
   
        '输入用户想要拆分的工做表
        Dim sheet_name
        sheet_name = Application.InputBox("请输入拆分工做表的名称：")
        Worksheets(sheet_name).Select
   
        '输入获取拆分须要的条件列
        Dim col_name
        col_name = Application.InputBox("请输入拆分依据的列号(如A):")
   
        '输入拆分的开始行，要求输入的是数字
        Dim start_row As Integer
        start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)
   
        '暂停屏幕更新
        Application.ScreenUpdating = False
   
        '工做表的总行数
        Dim end_row
        end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row
   
        '遍历计算全部拆分表，每一个拆分表的格式为"表名称,表行数"
        '对于二维数组，ReDim只能扩充最后一维，所以sheet_map行不变，扩充列
        Dim sheet_map(), sheet_index
        ReDim sheet_map(1, 0)
        sheet_map(0, 0) = Range(col_name & start_row).Value
        sheet_map(1, 0) = 1
        sheet_index = 0
   
        With Worksheets(sheet_name)
            Dim row_count, temp, i
            row_count = 0
            For i = start_row + 1 To end_row
                temp = Range(col_name & i).Value
                If temp = Range(col_name & (i - 1)).Value Then
                    sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
                Else
                    ReDim Preserve sheet_map(1, sheet_index + 1)
                    sheet_index = sheet_index + 1
                    sheet_map(0, sheet_index) = temp
                    sheet_map(1, sheet_index) = 1
                End If
            Next
        End With
   
        '根据前面计算的拆分表，拆分红单个文件
        Dim row_index
        row_index = start_row
        For i = 0 To sheet_index
            Workbooks.Add
            '建立最终数据文件夹
            Dim dir_name
            dir_name = ThisWorkbook.Path & "\拆分出的表格\"
            If Dir(dir_name, vbDirectory) = "" Then
                MkDir (dir_name)
            End If
            '建立新工做簿
            Dim workbook_path
            workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xlsx"
            ActiveWorkbook.SaveAs workbook_path
            ActiveSheet.Name = sheet_map(0, i)
            '激活当前工做簿，ThisWorkbook表示当前跑代码的工做簿
            ThisWorkbook.Activate
   
            '拷贝条目数据(即最前面不须要拆分的数据行)
            Dim row_range
            row_range = 1 & ":" & (start_row - 1)
            Worksheets(sheet_name).Rows(row_range).Copy
            Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial
            '拷贝拆分表的专属数据
            row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
            Worksheets(sheet_name).Rows(row_range).Copy
            Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A" & start_row).PasteSpecial
            row_index = row_index + sheet_map(1, i)
   
            '保存文件
            Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=True
        Next
   
        '进行屏幕更新
        Application.ScreenUpdating = True
   
        MsgBox "拆分工做表完成"
   
      End Sub

彷佛，博客的代码着色功能不是好呀，看着让人感受好费力，再给你们上两张看着舒服的图片吧。