如何快速拆分excel工作表

发布网友 发布时间：2022-03-06 06:46

我来回答

共1个回答

热心网友 时间：2022-03-06 08:15

Sub 拆分为工作薄()

Dim d As Object

Dim i, f As Integer

Dim wb As Workbook

Set d = CreateObject("Scripting.Dictionary")

Dim arr As Variant

arr = Sheets("汇总").Range("a1").CurrentRegion

For i = 3 To UBound(arr)

d(arr(i, 1)) = ""

Next i

For Each k In d.keys

Application.SheetsInNewWorkbook = 1

Set wb = Workbooks.Add

For i = 3 To UBound(arr)

If ThisWorkbook.Worksheets("汇总").Cells(i, 1) = k Then

ThisWorkbook.Worksheets("汇总").Rows("1:2").Copy wb.Worksheets(1).[a1]

ThisWorkbook.Worksheets("汇总").Rows(i).Copy

wb.Worksheets(1).Columns(1).Cells(wb.Worksheets(1).Columns(1).Cells.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

End If

Next i

f = wb.Worksheets(1).Columns(36).Cells(wb.Worksheets(1).Columns(36).Cells.Count).End(xlUp).Row + 1

wb.Worksheets(1).Cells(f, 36) = Application.Sum(wb.Worksheets(1).Range(wb.Worksheets(1).Cells(3, 36), wb.Worksheets(1).Cells(f - 1, 36))) / (f - 3)

wb.Worksheets(1).Cells(f, 37) = Application.Sum(wb.Worksheets(1).Range(wb.Worksheets(1).Cells(3, 37), wb.Worksheets(1).Cells(f - 1, 37))) / (f - 3)

wb.Worksheets(1).Cells(f, 38) = Application.Sum(wb.Worksheets(1).Range(wb.Worksheets(1).Cells(3, 38), wb.Worksheets(1).Cells(f - 1, 38))) / (f - 3)

For Each a In wb.Worksheets(1).Shapes

a.Delete

Next

wb.Worksheets(1).Name = k

wb.SaveAs Filename:=ThisWorkbook.Path & "\拆分\" & k & ".xls"

wb.Close False

Next

End Sub