VBA / Excel 使用VBA分割工作表並另存新檔

VBA / Excel 使用VBA分割工作表並另存新檔

Post Views: 645

這個練習其實是很久之前VBA的課程內容

透過VBA利用篩選的功能來分割工作表

由於最近剛好工作上有這個需求，所以修改了程式碼來處理

後來覺得可以比照之前的「VBA / Excel 使用VBA在Word檔內進行尋找取代的方法 2」增加一些功能與介面以方便使用

操作介面

A欄 如果有多筆資料但是沒有要同時執行時，可以留空

B欄 透過選取檔案按鈕取得檔案的完整路徑

C欄 手動設定，要分割B欄檔案的哪一個工作表

D欄 手動設定，分割/篩選的依據欄位

E欄 手動設定，工作表的總欄數

F欄 手動設定，要另存成新的工作簿或者PDF

刪除按鈕

刪除介面上的資料，透過 InputBox來設定刪除的列數範圍

由於 InputBox如果沒有輸入內容或者按取消

會得到空字串

而且輸入數字時，資料型態還是字串類型

所以定義類型的時候，定義為Variant

這樣透過IsNumeric判斷是否為數字型態的字串

如果是的話，就用CInt()轉型為數字

備註：如果先定義為 字串

之後用 r1 = CInt(r1)，r1 仍然會是字串

必須要重新定義

例如：再宣告一個變數 cr1為 整數型態

這樣 cr1 = CInt(r1)就會是整數型態了

如果不是的話，就跳出訊息並結束程序

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
 
Sub delRange()
    Dim r1 As Variant
    Dim r2 As Variant
    Dim Message1, Message2, Title As String
    
    Message1 = "請輸入起始列數"
    Message2 = "請輸入結束列數"
    Title = "設定刪除範圍"
    
    r1 = InputBox(Message1, Title)
    r2 = InputBox(Message2, Title)
    
    If IsNumeric(r1) And IsNumeric(r2) Then
        r1 = CInt(r1)
        r2 = CInt(r2)
    Else
        MsgBox "請確認範圍"
        Exit Sub
    End If
    
'    Debug.Print TypeName(r1)
'    Debug.Print TypeName(r2)
    
    If r1 <> 1 And r1 <> 0 And r2 <> 1 And r2 <> 0 And r2 >= r1 Then
        Sheets(1).Range("B" & r1 & ":" & "F" & r2).Clear
    Else
        MsgBox "請確認範圍"
    End If
    
End Sub

 

選取檔案按鈕

將檔案的完整路徑寫入B欄

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 
Sub cmdSelectFile()
    Dim fd As FileDialog    '宣告一個檔案對話框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
    
    fd.Filters.Clear    '清除之前的資料
    
    fd.InitialFileName = ActiveWorkbook.Path & Application.PathSeparator '設定初始目錄
    
    fd.Filters.Add "Word File", "*.xls*" '設定顯示的副檔名
    fd.Filters.Add "所有檔案", "*.*"
        
    fd.Show '顯示對話框
    
    Dim startx As Integer
    startx = Sheets(1).Range("B1000").End(xlUp).Row    '工作表已選取檔案數
'    MsgBox startx
    
    Dim i As Integer
    For i = 1 To fd.SelectedItems.Count
        Dim strFullName As String
        strFullName = fd.SelectedItems(i)
        
        '在B欄寫入檔案路徑與名稱
        Sheets(1).Cells(i + startx, 2) = strFullName
    Next i
    
End Sub

 

執行按鈕

將流程拆解，並分別為不同的子程序

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Sub main()
    Application.ScreenUpdating = False
    
    Dim d1 As String
    Dim f1 As String
    Dim rAll As Integer
    Dim s1 As Integer
    Dim c1 As Integer
    Dim c2 As Integer
    Dim p1 As String
    
    rAll = Sheets(1).Range("B100").End(xlUp).Row
    
    For i = 2 To rAll
        d1 = Sheets(1).Range("A" & i).Value  '是否執行
        If d1 <> "" Then
            f1 = Sheets(1).Range("B" & i).Value   '來源工作"簿"路徑
            s1 = Sheets(1).Range("C" & i).Value   '來源工作"表"序號
            c1 = Sheets(1).Range("D" & i).Value   '分割依據欄位數
            c2 = Sheets(1).Range("E" & i).Value   '來源工作表總欄位數
            p1 = Sheets(1).Range("F" & i).Value   '另存檔案格式
            
            If Not fi <> "" And s1 <> 0 And c1 <> 0 And c2 <> 0 Then
            
                Call copySheet(f1, s1)         '建立來源工作表
                Call getFilter(c1)             '建立分割依據工作表
                Call separationSheets(c1, c2)  '分割來源工作表
                
                If p1 = "pdf" Then
                    Call saveAsPDF              '轉存成PDF
                Else
                    Call saveAsWB               '另存新工作簿
                End If
                
                Call delSheets                 '刪除臨時工作表
            
            Else
                MsgBox "請確認相關設定"
                Exit Sub
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

總共有6個子程序

copySheet(filePath As String, index As Integer) 建立來源工作表

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
'依據序號從來源工作簿複製建立來源工作表
Sub copySheet(filePath As String, index As Integer)

    Dim sourceWb As Workbook
    Dim workWb As Workbook
    Dim fileOne As String
    Dim iOne As Integer
    
    fileOne = filePath
    iOne = index
    
    Set sourceWb = Workbooks.Open(fileOne)
    Set workWb = Workbooks("分割工作表.xlsm")
    
    sourceWb.Sheets(iOne).Copy After:=workWb.Sheets(workWb.Sheets.Count)
    
    workWb.Sheets(workWb.Sheets.Count).Name = "來源"
    
    sourceWb.Close
    
    Set sourceWb = Nothing
    Set workWbWb = Nothing
    
End Sub

getFilter(field As Integer) 建立分割依據工作表

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
'取得篩選依據
Sub getFilter(field As Integer)

    Dim cOne As Integer
    Dim workWb As Workbook
    Dim fSheet As Worksheet
    Dim inSheet As Worksheet
    Dim rOne As Integer
     
    cOne = field
    
    Set workWb = Workbooks("分割工作表.xlsm")
    
    Set inSheet = workWb.Sheets("來源")
    Set fSheet = workWb.Sheets.Add(After:=workWb.Sheets(workWb.Sheets.Count))
    
    fSheet.Name = "分割依據"
    
    rOne = inSheet.Cells(1, cOne).End(xlDown).Row
    inSheet.Activate
   
    inSheet.Range(Cells(1, cOne), Cells(rOne, cOne)).Copy fSheet.Range("A1")
    
    fSheet.Activate
    
    ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlYe

End Sub

 

separationSheets(field1 As Integer, field2 As Integer) 分割來源工作表

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
 
'分割來源工作表
Sub separationSheets(field1 As Integer, field2 As Integer)
    Application.ScreenUpdating = False
    
    Dim fOne As Integer
    Dim cOne As Integer
    
    fOne = field1
    cOne = field2
    
    For i = 2 To Sheets("分割依據").Range("A2").End(xlDown).Row
        '篩選依據
        X = Sheets("分割依據").Range("A" & i)
        
        '如果有重複名稱工作表則刪除
       
        For j = 4 To Sheets.Count
        
            If Sheets(j).Name = X Then
            '關閉警告提示
            Application.DisplayAlerts = False
               
               Sheets(j).Delete
               
            '開啟警告提示
            Application.DisplayAlerts = True
               Exit For
            End If
        Next
        
        Sheets("來源").Activate
        Range("A1").Activate
        
        '判斷工作表是否已經開啟自動篩選
        '如果已經開啟 則關閉
        
        '方法1
        '利用AutoFilter 是物件屬性
        '物件不存在  物件屬性 Is Nothing
        '物件存在    Not 物件屬性 Is Nothing
        
        'If Not Sheets(1).AutoFilter Is Nothing Then
        '    Selection.AutoFilter
        'End If

        '方法2
        '用AutoFilterMode來判斷
        '只能從true改成 false
        '不能從false改成true
        
        If Sheets("來源").AutoFilterMode = True Then
            Sheets("來源").AutoFilterMode = False
        
        End If
        
        Selection.AutoFilter
        
        rAll = Sheets("來源").Range("A1").End(xlDown).Row '總列數
        
        Sheets("來源").Range(Cells(1, 1), Cells(rAll, cOne)).AutoFilter field:=fOne, Criteria1:=X
       
        '假如沒有資料  只有第一列 向下偵測會到1048576列
        '<1048576列 表示有資料
        
        r1 = Sheets("來源").Range("A1").End(xlDown).Row  '篩選過後的列數
        
        If r1 < 1048576 Then
            
            Sheets("來源").Range(Cells(1, 1), Cells(r1, cOne)).Copy
            
            '新增工作表
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = X
            
            Sheets(X).Range("A1").PasteSpecial Paste:=xlPasteAll

            'Selection.Columns.AutoFit
        
            Application.CutCopyMode = False
            
            Sheets("來源").Activate
            Selection.AutoFilter
             
        End If
    Next

    '複製總表的欄位寬度
    For s = 4 To Sheets.Count
         Sheets("來源").Activate
         Sheets("來源").Range(Cells(1, 1), Cells(1, cOne)).Copy

         Sheets(s).Activate
         Range("A1").Activate

        '貼上總表的欄位寬度
         Selection.PasteSpecial Paste:=xlPasteColumnWidths

         '自動調整列高
         Selection.Rows.AutoFit

         Application.CutCopyMode = False
         Range("A1").Select

     Next
     
        Sheets("來源").Select
        Application.CutCopyMode = False
        Range("A1").Select
        
        Application.ScreenUpdating = True
        
End Sub

 

saveAsPDF() 轉存成PDF

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
'另存新工作簿成PDF
Sub saveAsPDF()
 
    Application.ScreenUpdating = False
    sPath = ThisWorkbook.Path & "\output" & "\"
    
    If Dir(ThisWorkbook.Path & "\output", vbDirectory) = vbNullString Then
        MkDir ThisWorkbook.Path & "\output"
    End If
    
    Y = 1
    
    For i = 4 To Sheets.Count
        X = Sheets(i).Name
       
        Sheets(X).Copy
        With ActiveSheet.PageSetup
            .PaperSize = xlPaperA4
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & Y & "." & X & ".pdf"
        ActiveWorkbook.Close False
        Y = Y + 1
    Next
    
    Application.ScreenUpdating = True
    
    Call openOutput(ThisWorkbook.Path & "\output")
    
End Sub

 

其中還有一個子程序，開啟輸出的資料夾

openOutput(dirPath As String)

1
2
3
4
5
6
 
'開啟輸出資料夾
Sub openOutput(dirPath As String)
    Dim sPath As String
    sPath = dirPath
    Shell "explorer.exe " & sPath, vbNormalFocus
End Sub

 

saveAsWB() 另存新工作簿

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 
'另存新工作簿
Sub saveAsWB()
 
    Application.ScreenUpdating = False
    sPath = ThisWorkbook.Path & "\output" & "\"
    
    If Dir(ThisWorkbook.Path & "\output", vbDirectory) = vbNullString Then
        MkDir ThisWorkbook.Path & "\output"
    End If
    
    Y = 1
    
    For i = 4 To Sheets.Count
        X = Sheets(i).Name
       
        Sheets(X).Copy
        
        ActiveWorkbook.SaveAs Filename:=sPath & Y & "." & X & ".xlsx"
        ActiveWorkbook.Close False
        Y = Y + 1
    Next
    
    Application.ScreenUpdating = True
    
End Sub

 

delSheets() 刪除臨時工作表

1
2
3
4
5
6
7
8
9
 
'刪除工作表
Sub delSheets()
    '反向刪除
    For i = Sheets.Count To 2 Step -1
        Application.DisplayAlerts = False
        Sheets(i).Delete
        Application.DisplayAlerts = True
    Next
End Sub

 

Tags: