使用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

彷佛，博客的代碼着色功能不是好呀，看着讓人感受好費力，再給你們上兩張看着舒服的圖片吧。