將工作簿中的所有工作表單獨保存，原表仍然存在

1.原工作簿：

原工作簿

2.效果顯示：

單獨工作表

3.VBA代碼：

Sub chaifen()

'定義變量sht為工作表
Dim sht As Worksheet
'在所有工作表中遍歷一次
For Each sht In Sheets
'工作表復制
    sht.Copy
'目前活動的工作表另存為，注意路徑的寫法
    ActiveWorkbook.SaveAs Filename:="D:\C 文件\excel\VBA\day03\CHAIFEN\" & sht.Name & ".xlsx"
'目前活動的工作表關(guān)閉
    ActiveWorkbook.Close
Next
End Sub

4.知識點：
thisworkbook：指當前VBA代碼所處的 workbook
activeworkbook:指當前活躍的workbook
相同點：如果VBA代碼只對本身工作薄進行操作，則兩者相同；
不同點：如果VBA代碼新建或打開了其他工作薄，則往往新建或剛打開的是activeworkbook，可以通過"工作薄名.active"方法激活指定對象。

保留工作薄中不想刪除的工作表，其他全部刪除

1.原工作薄

絕不能刪除1.png

2.刪除后

絕不能刪除2.png

3.VBA代碼

Sub test()
'刪除其他表，保留 絕不能刪除 表
Dim sht As Worksheet

Application.DisplayAlerts = False

For Each sht In Sheets
'如果工作表名不等于“決不能刪除”
    If sht.Name <> "絕不能刪除" Then
    '將工作表刪除
        sht.Delete
    End If
Next

Application.DisplayAlerts = False

End Sub

4.知識點：
worksheet:單個工作表
worksheets:指定工作薄中所有工作表的集合
Application.DisplayAlerts：如果宏運行時Excel顯示特定的警告和信息，則該值為True。如果不想在宏運行時被無窮無盡的提示和警告消息困擾，則將該屬性設(shè)置為False。

利用空白工作薄控制創(chuàng)建新的工作薄并填寫內(nèi)容

1.VBA代碼

Sub chuangjian()
'新建工作薄
Workbooks.Add
'活動工作薄工作表1單元格a1填寫內(nèi)容“這是我自動創(chuàng)建出來的”
ActiveWorkbook.Sheets(1).Range("a1") = "這是我自動創(chuàng)建出來的"
'活動工作薄另存為到指定的文件路徑
ActiveWorkbook.SaveAs Filename:="D:\C 文件\excel\VBA\day03\123.xlsx"
End Sub

2.運行效果

123.png

123內(nèi)容.png

3.知識點：
Workbooks:對象是Microsoft Excel應用程序中當前打開的所有Workbook對象的集合，有Close、Add、Open等方法
Workbook:對象是一個Microsoft Excel工作薄，有name、path等屬性，有SaveAs等方法，有Open、Activate等事件
Workbooks.Add:新建工作薄，新建的工作薄將成為活動工作薄

利用空白工作薄控制已有的工作薄并填寫內(nèi)容

1.空白的工作表1

空白的工作表1

2.VBA代碼

Sub test()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'工作薄打開指定路徑下的1.xlsx
Workbooks.Open Filename:="D:\C 文件\excel\VBA\day03\1.xlsx"
'活動工作薄工作表1單元格a1填寫"又又到此一游"
ActiveWorkbook.Sheets(1).Range("a1") = "又又到此一游"
'活動工作薄保存
ActiveWorkbook.Save
'活動工作薄關(guān)閉
ActiveWorkbook.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

3.含內(nèi)容的工作表1

又又到此一游1.png

4.知識點：
Application.ScreenUpdating:在Excel的工作表里面數(shù)據(jù)發(fā)生變化后，F(xiàn)alse禁止實時刷新，True為默認值表示實時更新數(shù)據(jù)

按部門名稱來篩選數(shù)據(jù)

1.篩選數(shù)據(jù)

篩選數(shù)據(jù)

2.VBA代碼

Sub chaifen()

    Sheet1.Range("a1:F32").AutoFilter Field:=4, Criteria1:="一車間"

End Sub

3.篩選一車間

篩選一車間

將數(shù)據(jù)工作表取消篩選狀態(tài)

1.篩選狀態(tài)

篩選狀態(tài)

2.VBA代碼

Sub qxshaixuan()
    
    Sheet1.Range("a1:F32").AutoFilter

End Sub

3.取消篩選

取消篩選

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.01

【注意事項】：分表已經(jīng)提前做好，需要拷貝數(shù)據(jù)到分表中
1.如下所示：

工作表-數(shù)據(jù)

按照數(shù)據(jù)表部門，分別實現(xiàn)以部門名稱建立的新表，然后將數(shù)據(jù)表中部門名稱單元格所在行復制到新表中。

2.代碼如下：

Sub chaifen1()

'實現(xiàn)功能：將數(shù)據(jù)表中Range("d" & i)單元格對應的行數(shù)據(jù)拆分到新表Range("d" & i).value名稱的表中

    '定義整型數(shù)據(jù)i,k,j
    Dim i,k,j As Integer
           
    '遍歷第二個工作表到最后一個工作表
    For j = 2 To Sheets.Count
    
        '將工作表數(shù)據(jù)中的抬頭拷貝到其他工作表中去
        Sheet1.Range("a1").Resize(1, 6).Copy Sheets(j).Range("a1")
    
        '遍歷數(shù)據(jù)表中第二行到最后一行數(shù)據(jù)
        For i = 2 To Sheets(1).Range("a65536").End(xlUp).Row
        
            '假如數(shù)據(jù)表單元格("d" & i)單元格對應的值等于表二的名稱
            If Sheet1.Range("d" & i).Value = Sheets(j).Name Then
            
                '計算表二目前狀態(tài)下已有多少行數(shù)據(jù)
                k = Sheets(j).Range("a65536").End(xlUp).Row
                
                '將數(shù)據(jù)表中Range("d" & i)單元格所在整行數(shù)據(jù)拷貝到數(shù)據(jù)表中已有行數(shù)的下一行
                Sheet1.Range("d" & i).EntireRow.Copy Sheets(j).Range("a" & k + 1)  
            End If
        Next
    Next 
End Sub

3.得到效果：

工作表-二車間

工作表-一車間

在分表中出現(xiàn)小數(shù)點，暫時還未知原因！

4.知識點：
{1}、在保存含有VBA代碼的文件時，在警告提示中選擇否，保存格式為xlsm，即可保存成功
{2}、Sheets.Count:獲取本工作薄中工作表的總數(shù)
{3}、Sheets(Sheets.Count):調(diào)用排在最后一位的工作表
{4}、Sheets(Sheets.Count).Name:獲取最后一個工作表的名稱

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.02

【注意事項】：分表已經(jīng)提前做好，需要拷貝數(shù)據(jù)到分表中
【使用方法】：利用excel篩選功能提高效率
1.工作簿表們

工作簿表們

2.VBA代碼

Sub shaifen()
'定義整型變量i
Dim i As Integer
'從第二張工作表開始遍歷
For i = 2 To Sheets.Count
'根據(jù)工作表名稱來篩選數(shù)據(jù)工作表
    Sheet1.Range("a1:F32").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
'將篩選后的數(shù)據(jù)工作表復制到第i張工作表的a1單元格
    Sheet1.Range("a1:F32").Copy Sheets(i).Range("a1")
Next
'取消數(shù)據(jù)工作表的篩選
    Sheet1.Range("a1:F32").AutoFilter
End Sub

3.執(zhí)行篩選復制程序后

財務部1.png

二車間1.png

技改辦1.png

經(jīng)理室1.png

人力資源部1.png

銷售1部1.png

銷售2部1.png

一車間1.png

4.知識點：
Sheets(i).Name:第i張工作表的名稱

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.03

【注意事項】：分表未提前做好，需要拷貝數(shù)據(jù)到分表中
【使用方法】：判斷建表結(jié)合篩選功能提高拆分表效率
1.數(shù)據(jù)工作表

20190117-數(shù)據(jù)工作表

2.VBA代碼

Sub chaifenshuju()
'定義工作表變量sht
Dim sht As Worksheet
'定義整型變量k,i,j
Dim k, i, j As Integer
Dim irow As Integer '此處定義一個一共多少行的整數(shù)值

irow = Sheet1.Range("a65536").End(xlUp).Row

'1此處是建立新工作表的代碼
'此處為一個標準遍歷寫法，需要記住
For i = 2 To irow
'將標記值復位，便于創(chuàng)建未重名新工作表
    k = 0

    For Each sht In Sheets
        
        If sht.Name = Sheet1.Range("d" & i) Then
        
            k = 1
        
        End If
    
    Next
    
    If k = 0 Then
    '按部門名稱來創(chuàng)建新工作表
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Range("d" & i)
        
    End If
    
Next

'此處是將數(shù)據(jù)表中的數(shù)據(jù)按部門進行拷貝到對應部門的工作表中

For j = 2 To Sheets.Count

    Sheet1.Range("a1:f" & irow).AutoFilter Field:=4, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")

Next
    '數(shù)據(jù)工作表取消或者選中篩選狀態(tài)
    Sheet1.Range("a1:f" & irow).AutoFilter

End Sub

3.拆分后效果

20190117-財務部.png

20190117-二車間.png

20190117-技改辦.png

20190117-經(jīng)理室.png

20190117-人力資源部.png

20190117-銷售1部.png

20190117-銷售2部.png

20190117-一車間.png

針對MsgBox以及InputBox的測試

1.測試代碼

Sub test()

    MsgBox "你好！"

End Sub

【效果展示】

20190117-你好

2.測試代碼1

Sub test1()

    InputBox "你幾歲了？"

End Sub

【效果展示】

20190117-你幾歲了.png

3.測試代碼2

Sub test2()

    Dim i As Integer
    
    i = InputBox("你幾歲了？")
    
    Sheet1.Range("A1") = i

End Sub

【效果展示】

20190117-輸入5后變化.png

20190117-3變成5.png

4.測試代碼3

Sub test3()

    Dim i As Integer
    
    i = InputBox("你幾歲了？")
    
    MsgBox "哦，原來你6歲啦"

End Sub

【效果展示】

20190117-輸入7.png

5.測試代碼4

Sub test4()

    Dim i As Integer
    
    i = InputBox("你幾歲了？")
    
    MsgBox "哦，原來你" & i & "歲啦"

End Sub

【效果展示】

20190117-輸入10.png

20190117-與輸入10一致.png

6.測試代碼5

Sub test5()

    Range("A1").Select

End Sub

【效果展示】

20190117-A1選中.png

7.測試代碼6

Sub test6()

    Cells(4, 1).Select

End Sub

【效果展示】

20190117-A4選中.png

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.04

【注意事項】：分表未提前做好，需要拷貝數(shù)據(jù)到分表中
【使用方法】：在NO.03的基礎(chǔ)上再升級成最終版本
1.使用控件

使用控件

2.VBA代碼

Sub chaifenshuju()

Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '此處定義一個一共多少行的整數(shù)值
Dim l As Integer

l = InputBox("請輸入你要按哪列分")


'創(chuàng)建新表之前，刪除除數(shù)據(jù)工作表之外的其他工作表
'消除提示
Application.DisplayAlerts = False
If Sheets.Count > 1 Then

    For Each sht1 In Sheets
    
        If sht1.Name <> "數(shù)據(jù)" Then
        
            sht1.Delete
        
        End If
    
    Next

End If

'消除提示
Application.DisplayAlerts = False


irow = Sheet1.Range("a65536").End(xlUp).Row
'1此處是建立新工作表的代碼
'此處為一個標準遍歷寫法，需要記住
For i = 2 To irow

    k = 0

    For Each sht In Sheets
        
        If sht.Name = Sheet1.Cells(i, l) Then
        
            k = 1
        
        End If
    
    Next
    
    If k = 0 Then
    
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
        
    End If
    
Next

'此處是將數(shù)據(jù)表中的數(shù)據(jù)按部門進行拷貝到對應部門的工作表中

For j = 2 To Sheets.Count

    Sheet1.Range("a1:f" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")

Next
    '數(shù)據(jù)取消或者選中篩選狀態(tài)
    Sheet1.Range("a1:f" & irow).AutoFilter
    
    Sheet1.Select
    
    MsgBox "已經(jīng)執(zhí)行完畢！"

End Sub

3.執(zhí)行效果

20190118-按第四列來分

20190118-按第五列來分

4.功能：可以按照列數(shù)來進行拆分工作表

按工作表1中單元格內(nèi)容進行創(chuàng)建新工作表

1.Sheet1

Sheet1.png

2.VBA代碼-No.01

Sub xinjianbiao01()

    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Sheet1.Range("a1")

End Sub

3.VBA代碼-No.02

Sub xinjianbiao02()

    Sheets.Add(after:=Sheets(Sheets.Count)).Name = Sheet1.Range("a2")

End Sub

4.執(zhí)行代碼后

1月2月.png

5.知識點：
Sheets.Add after:=Sheets(Sheets.Count):在最后一張工作表后添加新工作表

按工作表1中單個單元格內(nèi)容進行創(chuàng)建新工作表

1.工作薄

Sheet1.png

2.VBA代碼
Sub xinjianbiao()

'此處k被定義為整數(shù)，默認初始值為0，可以看做是一個開關(guān)，判斷新表是否能夠建立
'此處是針對工作表1單元格a1進行創(chuàng)建新表

Dim sht As Worksheet
Dim k As Integer

'遍歷目前已經(jīng)存在的工作表
For Each sht In Sheets
'如果存在工作表名與制定單元格值相同，則給k賦值1
If sht.Name = Sheet1.Range("a1") Then

    k = 1

End If

'如果k值為0，則說明存在工作表名與制定單元格值沒有相同

If k = 0 Then

Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("a1")

End If

End Sub
3.執(zhí)行代碼后

1月2月.png

4.知識點：
此處設(shè)置整數(shù)變量k作為標記值，來判斷同工作薄中工作表是否有重復名稱，如果沒有則新建，如果有則不會另外新建

按工作表1中多個單元格內(nèi)容進行創(chuàng)建新工作表

1.工作表1

工作表123月.png

2.VBA代碼

Sub xinjianbiao1()

'此處k被定義為整數(shù)，默認初始值為0，可以看做是一個開關(guān)，判斷新表是否能夠建立
'此處是針對工作表1單元格a1進行創(chuàng)建新表，如果要擴展到a2、a3的話，就需要對a1創(chuàng)建新表的內(nèi)容循環(huán)三次，并稍作修改
'定義工作表變量sht
    Dim sht As Worksheet
'定義整型變量k
    Dim k As Integer    
For i = 1 To 3

    '【血淚提醒】記得要恢復標記值k=0,不然一直為1狀態(tài)，就無法建立新工作表
    k = 0
    
    '遍歷目前已經(jīng)存在的工作表
    For Each sht In Sheets
        '如果存在工作表名與制定單元格值相同，則給k賦值1
        If sht.Name = Sheet1.Range("a" & i) Then
            k = 1
        End If
    Next
    
    '如果k值為0，則說明存在工作表名與指定單元格值沒有相同
    
    If k = 0 Then  
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Range("a" & i) 
    End If  
Next
End Sub

3.1月2月3月

1月2月3月.png

將分工作表內(nèi)容合并到數(shù)據(jù)工作表中

【提醒】前提已經(jīng)創(chuàng)建好數(shù)據(jù)工作表
1.分工作表

20190117-財務部.png

20190117-二車間.png

20190117-技改辦.png

20190117-經(jīng)理室.png

2.VBA代碼（有待優(yōu)化）

Sub hebingfenbiao()

'整型變量irow為分工作表的總行數(shù)，yrow為數(shù)據(jù)工作表總行數(shù)
Dim irow, yrow As Integer

'定義工作表變量sht
Dim sht As Worksheet

For Each sht In Sheets

    irow = sht.Range("a65536").End(xlUp).Row
    yrow = Sheets("數(shù)據(jù)").Range("a65536").End(xlUp).Row

    If sht.Name <> "數(shù)據(jù)" Then
                
        sht.Range("a1:f" & irow).Copy Sheets("數(shù)據(jù)").Range("a" & yrow + 1)
    
    End If

Next

'數(shù)據(jù)工作表A1單元格所在整行刪除
Sheets("數(shù)據(jù)").Range("A1").EntireRow.Delete

'最后數(shù)據(jù)工作表被選中
Sheets("數(shù)據(jù)").Select

'提示操作已經(jīng)執(zhí)行完畢！
MsgBox "已經(jīng)執(zhí)行完畢！！！"

End Sub

3.合并后效果

20190122 合并分表到數(shù)據(jù)工作表

錄制宏1，對某一單元格字體的大小進行修改

1.原單元格

原單元格大小

2.VBA代碼（此代碼是錄制的）

Sub 宏1()

    With Selection.Font
        .Name = "宋體"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
End Sub

3.執(zhí)行代碼后

執(zhí)行程序后單元格大小

4.對錄制宏代碼進行修改

Sub test1()

    Sheet2.Range("A1").Font.Size = 18

End Sub

5.執(zhí)行后效果

A1字體為18

對With的應用

1.未使用With的代碼

Sub test()

    Sheet2.Range("A1") = 6
    Sheet2.Range("A4") = 12
    Sheet2.Range("A5") = 8
    Sheet2.Range("A7") = 10

End Sub

2.使用With的代碼

Sub testxiugai()

    With Sheet2
    
        .Range("A1") = 6
        .Range("A4") = 12
        .Range("A5") = 8
        .Range("A7") = 10
    
    End With

End Sub

3.執(zhí)行后的效果一樣

With代碼執(zhí)行后

選中工作表中某單元格，則單元格所在整行標記某顏色

手動模式下的整行變色

1.手動模式下整行變色

手動模式下整行變色

2.VBA代碼
【代碼位置】代碼在模塊2中

模塊2中的代碼

Sub ChangeColor()
    '所有單元格背景色=無填充顏色
    Cells.Interior.Pattern = xlNone
    '選擇單元格或者多個單元格（選區(qū)）所在整行背景顏色填充為黃色
    Selection.EntireRow.Interior.Color = 65535
     '選擇單元格或者多個單元格（選區(qū)）所在整列背景顏色填充為黃色
    'Selection.EntireColumn.Interior.Color = 65535
End Sub

3.【弊端】在每次點擊其他單元格或區(qū)域后，必須要點擊宏，選擇ChangeColor宏執(zhí)行后才會有效果，不會自動。

自動模式下的整行變色

1.自動模式下的整行變色

自動模式下整行變色

2.VBA代碼
【代碼位置】代碼在Sheet1

代碼在Sheet1中

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    '工作表選區(qū)發(fā)生變化，此sub是自動執(zhí)行，不需要每次點擊并選擇宏
    '此處是事件，如果發(fā)生了某事，則會自動執(zhí)行代碼
    
    Cells.Interior.Pattern = xlNone
    Selection.EntireRow.Interior.Color = 65535      
End Sub

3.【好處】每當單元格點擊發(fā)生變化后，觸發(fā)事件，自動執(zhí)行事件中包含的代碼，不用再去點擊宏啦！！！

按工作表1中單元格內(nèi)容進行創(chuàng)建新工作表

三个男躁一个女,国精产品一区一手机的秘密,麦子交换系列最经典十句话,欧美国产综合欧美视频

EXCEL | VBA實例操作

EXCEL | VBA實例操作

將工作簿中的所有工作表單獨保存，原表仍然存在

保留工作薄中不想刪除的工作表，其他全部刪除

利用空白工作薄控制創(chuàng)建新的工作薄并填寫內(nèi)容

利用空白工作薄控制已有的工作薄并填寫內(nèi)容

按部門名稱來篩選數(shù)據(jù)

將數(shù)據(jù)工作表取消篩選狀態(tài)

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.01

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.02

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.03

針對MsgBox以及InputBox的測試

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.04

按工作表1中單元格內(nèi)容進行創(chuàng)建新工作表

按工作表1中單個單元格內(nèi)容進行創(chuàng)建新工作表

按工作表1中多個單元格內(nèi)容進行創(chuàng)建新工作表

將分工作表內(nèi)容合并到數(shù)據(jù)工作表中

錄制宏1，對某一單元格字體的大小進行修改

對With的應用

選中工作表中某單元格，則單元格所在整行標記某顏色

手動模式下的整行變色

自動模式下的整行變色

3.【好處】每當單元格點擊發(fā)生變化后，觸發(fā)事件，自動執(zhí)行事件中包含的代碼，不用再去點擊宏啦！！！

按工作表1中單元格內(nèi)容進行創(chuàng)建新工作表

推薦閱讀更多精彩內(nèi)容

三个男躁一个女,国精产品一区一手机的秘密,麦子交换系列最经典十句话,欧美 国产 综合 欧美 视频

EXCEL | VBA實例操作

將工作簿中的所有工作表單獨保存，原表仍然存在

保留工作薄中不想刪除的工作表，其他全部刪除

利用空白工作薄控制創(chuàng)建新的工作薄并填寫內(nèi)容

利用空白工作薄控制已有的工作薄并填寫內(nèi)容

按部門名稱來篩選數(shù)據(jù)

將數(shù)據(jù)工作表取消篩選狀態(tài)

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.01

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.02

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.03

針對MsgBox以及InputBox的測試

將工作表數(shù)據(jù)按照部門拆分到部門名稱所對應的工作表中-No.04

按工作表1中單元格內(nèi)容進行創(chuàng)建新工作表

按工作表1中單個單元格內(nèi)容進行創(chuàng)建新工作表

按工作表1中多個單元格內(nèi)容進行創(chuàng)建新工作表

將分工作表內(nèi)容合并到數(shù)據(jù)工作表中

錄制宏1，對某一單元格字體的大小進行修改

對With的應用

選中工作表中某單元格，則單元格所在整行標記某顏色

手動模式下的整行變色

自動模式下的整行變色

3.【好處】每當單元格點擊發(fā)生變化后，觸發(fā)事件，自動執(zhí)行事件中包含的代碼，不用再去點擊宏啦！！！

按工作表1中單元格內(nèi)容進行創(chuàng)建新工作表

推薦閱讀更多精彩內(nèi)容

三个男躁一个女,国精产品一区一手机的秘密,麦子交换系列最经典十句话,欧美国产综合欧美视频