VBA 表格操作2 表格复制

office excel文件有工作簿，里面存放一张张表，表的名字叫做标签名，簿名就是我们常见的的文件名，簿的类型有“一簿一表”与“一簿多表”。

完成将多张表合并到一个工作簿中，并为表标签命名，增加制表日期。

簿与簿直接的操作基本如下：

1.一簿一表之间的复制 一对一

2.多个一簿一表的合并

3.多个一簿多表与一簿一表的合并

现在在目录下新建文件夹test，并在里面新建2个一簿3表的excel文件li1,li2,其中li1中3张表的标签分别为a\b\c,li2中表的标签分别为1、2、3，1个一簿1表的excel文件li0,表标签为0.

如图所示

一簿一表之间的复制

Sub 一簿一表之间的复制
Application.ScreenUpdating = F
Dim wb As Workbook
    filename = "C:\Users\liyi\Desktop\test" & "\li1.xlsx"
    Set wb = Workbooks.Add
    Dim tempwb As Workbook
    Set tempwb = GetObject(filename)
        tempwb.Worksheets(1).Copy before:=wb.Worksheets(wb.Worksheets.Count)
        wb.SaveAs ThisWorkbook.Path & "\一簿一表之间的复制.xlsx"
        wb.Close
End Sub

这样就把li1中的表a,复制到新建的表中，并插在默认第一张表之前。

结果如图

多个一簿一表之间的合并

Sub 多个一簿一表的合并()
Application.ScreenUpdating = F
Dim wb As Workbook, filename As String
    filename = Dir("C:\Users\liyi\Desktop\test" & "\li*.xlsx")  ' dir函数遍历文件，并将文件名赋值给filename
    Set wb = Workbooks.Add
    Dim tempwb As Workbook, fn As String
    Do While filename <> ""
    fn = "C:\Users\liyi\Desktop\test" & "\" & filename   '将文件路径赋值给fn
    Set tempwb = GetObject(fn)                           '获取到该文件
        tempwb.Worksheets(1).Copy before:=wb.Worksheets(wb.Worksheets.Count)
        ActiveSheet.Name = Left(filename, Len(filename) - 5) & "_" & tempwb.Worksheets(1).Name
        '以工作簿的名字加上"_"加上表标签为新簿中的表命名
        filename = Dir
        Loop
        Application.DisplayAlerts = False  '“删除工作表警告提示” 取消
        Sheets("sheet1").Delete            '删除新建簿时默认生成的sheet1
        Application.DisplayAlerts = True
        wb.SaveAs ThisWorkbook.Path & "\多个一簿一表的合并.xlsx"
        wb.Close
End Sub

新簿是将3个文件中的第一张表复制到新簿，并重新命名

结果如图：

多个一簿多表的合并

Sub 多个一簿多表的合并()
Application.ScreenUpdating = F
Dim wb As Workbook, filename As String, fn As String
    filename = Dir("C:\Users\liyi\Desktop\test" & "\li*.xlsx")
    Set wb = Workbooks.Add
    Dim tempwb As Workbook
    Do While filename <> ""
       fn = "C:\Users\liyi\Desktop\test" & "\" & filename
        Set tempwb = GetObject(fn)
            Dim sht As Worksheet
            For Each sht In tempwb.Worksheets
            sht.Copy before:=wb.Worksheets(wb.Worksheets.Count)
             ActiveSheet.Name = Left(filename, Len(filename) - 5) & "_" & sht.Name
            Next
        filename = Dir
    Loop
        Application.DisplayAlerts = False  '“删除工作表警告提示” 取消
        Sheets("sheet1").Delete
        Application.DisplayAlerts = True
        yue = Month(Date - 1)
        ri = Day(Date - 1)
        wb.SaveAs ThisWorkbook.Path & "\多个一簿多表的合并()" & yue & ri & ".xlsx"
        wb.Close
End Sub

结果如图