1 excel(vba) 如何导表 提高效率 ? 学会这个方法，你会有大把时间喝咖啡

1.自动处理工作表之 新建工作簿

Sub qqq()
	'读取表名，赋值给str1
    For i = 2 To 5
    str1 = Range("g" & i)
	'选择内容，数据透视表中按车间选择
    ActiveSheet.PivotTables("数据透视表2").PivotFields("车间").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表2").PivotFields("车间").CurrentPage = str1
    Range("I5:K18").Select
    Selection.Copy
    
   '录制宏中不获得新建工作簿（Excel文件）
    Workbooks.Add
    ActiveWorkbook.Sheets("Sheet1").Select
   	Range("A1").Select
    ActiveWorkbook.ActiveSheet.Paste
    
    '保存的路径名称
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path + "\" + str1 + ".xlsx"
    ActiveWindow.Close
   'debug一下路径
    Debug.Print ThisWorkbook.Path
    '+ "\" + str1 + ".xlsx"
    
   ' 结束后回到原工作表
    Windows("车间数据bbbbb.xlsx").Activate
    Sheets("Sheet1").Select
    
    Next
End Sub

结果 自动新建了4个表格文件

---

2.自动处理工作表之 新建工作表

Sub aaaa()
For i = 2 To 5
Dim car As String
'选中表格
'让表格中 gI 的值等于car
Sheets("Sheet1").Select
    car = Range("g" & i)
'录制宏获取透视表筛选代码
    ActiveSheet.PivotTables("数据透视表2").PivotFields("车间").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表2").PivotFields("车间").CurrentPage = car
    Range("I5:K17").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
'更改表名
    Sheets(i).Name = car
    Next
End Sub

结果 直接在表内生成4个sheet工作表

3.自动处理工作表之 新建到 Word文档

Sub a1()
For i = 1 To 4
    'case
    '创建应用
    Set wdapp = CreateObject("word.application")
    '创建Word文档
    wdapp.documents.Add
    '显示应用
    wdapp.Visible = True
    num = Application.CountIf(Range("a:a"), Range("f" & i))
    '创建表格
    wdapp.documents(1).Tables.Add Range:=wdapp.Selection.Range, NumRows:=num + 1, NumColumns:=4
    '更改样式
    wdapp.documents(1).Tables(1).Style = "浅色底纹 - 强调文字颜色 3"
    '创建第一行的标题头
    n = 1
    For j = 1 To 4
    wdapp.documents(1).Tables(1).Range.Cells(n) = Cells(1, j)
    n = n + 1
    Next
    
    '内容搬运模块
    For k = 2 To Application.CountA(Range("a:a"))
        If Range("a" & k) = Range("f" & i) Then
            For m = 1 To 4
            wdapp.documents(1).Tables(1).Range.Cells(n) = Cells(k, m)
                n = n + 1
            Next
        End If
    Next
    
'另存为
wdapp.documents(1).SaveAs ThisWorkbook.Path + "\" + Range("f" & i) + ".docx"
'退出
wdapp.Quit

Next
End Sub

练习资源地址：https://pan.baidu.com/s/1Y3d0n0BSkRk8CUwr8o-CIA

查看专栏详情 立即解锁全部专栏