使用VBA編程自動以exce表中的指定列分離出工作表

寫了一個VBA宏程序，用來自動將EXCEL一列轉換爲不同的工作表。例如：

姓名  性別

張三  男

李四  女

通過該程序可以自動分離出“男”工作表和“女”工作表。先上代碼，註釋寫的很清楚。

在excel中先使用alt+F11組合鍵打開代碼窗口，在當前項目中新建一個模塊（modules），複製代碼到當前模塊。使用ctrl+G打開調試窗口，複製代碼並執行。

'時間：2/6/2015
'版本：1.0

'宏SeperateColumn用來將當前工作表，按某一列進行分類，每一類新建爲以該值變量命名的工作表中，工作表第一行爲表頭，不進行分離;
'注意：使用前請提前備份工作簿，最好先搜索目標列確認列值符合工作表命名規範

Sub SeperateColumn()

  '定義了需要分離的列
  Dim col As Integer
  
  '從選擇的行開始進行迭代分離col列*********************
  col = getSeperateCol()
  
 
     '取得當前工作表的最大行數tableRows
     Dim tableRows As Integer
     tableRows = ActiveSheet.Range("A65535").End(xlUp).Row
     
     '取得當前工作表的名字
     Dim tableName As String
     tableName = ActiveSheet.Name()
     
        '對當前工作表從第二行開始迭代（第一行爲表頭），取col列的值進行處理
        Dim stringEveryItem As String
        For Index = 2 To tableRows
        
            stringEveryItem = ActiveSheet.Cells(Index, col)
            
            '如果此值在所有的工作表中五法找到則新建一個該名稱的工作表並且將該行插入
            If stringExistWorkSheet(stringEveryItem) = False Then
               resultAddsheet = addWorkSheetCopyFirstRow(tableName, stringEveryItem)
               resultInsertSheet = copyRowToWorksheet(tableName, Index, stringEveryItem)
                
            '若此值在所有工作表中能找到，則直接插入到該工作表中
            Else
               resultInsertExistSheet = copyRowToWorksheet(tableName, Index, stringEveryItem)
            End If
        Next
                
  Debug.Print "轉換完成"
  
  MsgBox "轉換完成 Seperate Completed.", vbInformation, "運行結果RESULT"
        
  
End Sub

'函數stringExistWorkSheet()判斷通過值傳遞來的value_name是否在本workbook中存在該worksheet（這裏不區分大小寫）
Function stringExistWorkSheet(ByVal value_name As String) As Boolean
    
    '先定義一個Worksheet對象
    Dim sht As Worksheet
    
    '默認下找不到該Worksheet
    stringExistWorkSheet = False
    
    '下面對該Workbook進行遍歷
    For Each sht In ActiveWorkbook.Worksheets
        '比較時worksheet和value_name不區分大小寫
        If VBA.LCase(sht.Name) = VBA.LCase(value_name) Then
            stringExistWorkSheet = True
            Exit Function
            
        End If
    Next
End Function
'函數addWorkSheetCopyFirstRow(tableName,sName)用來新建一個以sName的工作表，並且將tableName工作表的第一行復制到新工作表的第一行
Function addWorkSheetCopyFirstRow(ByVal tableName As String, ByVal sName As String) As Boolean

    addWorkSheetCopyFirstRow = False

    '插入制定名稱的工作表
    Worksheets.Add.Name = sName
    
    Debug.Print "創建新工作表"; sName; "成功"
    
    '選中主表的第一行
     Worksheets(tableName).Activate
     Rows(1).Select
    '複製選中的第一行
    Selection.Copy
    
    '選中新建表的第一行
    Sheets(sName).Activate
    Rows(1).Select
    '粘貼
    ActiveSheet.Paste
    
    addWorkSheetCopyFirstRow = True
    Worksheets(tableName).Activate '最後將當前活動工作表還原爲主表
    
    Debug.Print "已經複製第一行到"; sName; "工作表"
    
End Function
'copyRowToWorksheet函數用來從tableNameCopy工作表中選取第tableNameCopyRow行，然後複製到tableNamePaste表中
Function copyRowToWorksheet(ByVal tableNameCopy As String, ByVal tableNameCopyRow As Single, ByVal tableNamePaste As String) As Boolean
    
    copyRowToWorksheet = False
    
    '首先將主表設爲活動表，選取某行進行復制
    Worksheets(tableNameCopy).Activate
    Rows(tableNameCopyRow).Select
    Selection.Copy
    
    '其次將要粘貼的目的表設爲活動表，選取其尾部的行進行粘貼
    Worksheets(tableNamePaste).Activate
    
    '這裏使用目的表的最後一行
    Dim rowNumber As Integer
    rowNumber = ActiveSheet.Range("A65535").End(xlUp).Row + 1
    
    Rows(rowNumber).Select
    ActiveSheet.Paste
    
  
    '粘貼成功後還原活動表
    copyRowToWorksheet = True
    Worksheets(tableNameCopy).Activate
    
End Function
'getSeperateCol函數通過使用inputbox提供用戶選擇輸入，用來獲得需要分離的列，這裏先使用數字，後續添加輸入列名的功能
Function getSeperateCol() As Integer
    Dim colIndex As Integer
    
    '這裏使用VBA.InputBox提供用戶交互
    colIndex = VBA.InputBox("請輸入需要分離的列序號（數字）Please input the index of the column which you want to seperate.(Integer)", "選擇框CHOOSEBOX")
    
    '這裏提供給用戶確認選擇框
    MsgBox "需要轉換的列序號 Column Index:" & colIndex, vbInformation, "提示NOTICE"
    
    getSeperateCol = colIndex
         
End Function
                            

簡述下自己的編程思想：

首先遍歷當前工作表的第二行至最後一行，根據選定的列進行迭代；這裏，通過拆分功能區域，將程序拆分出1.遍歷所有工作表名稱。2，新建工作表並複製第一行。3，複製某一行到目標工作表。4，用戶交互。4個函數區，分別實現測試，然後在主函數中調用。有效降低了編程的複雜性。