java给excel填充数据_Excel：跨多个工作表填充数据

这是两个VBA解决方案 . 第一个做到这一点：

检查是否存在工作表"totals" . 如果没有，请创建它

将第一张纸的第一行(A到Q)复制到"totals"

从第2行开始复制块A2：Q33到"totals"表

对所有其他工作表重复，每次减少32行

第二个显示如何在复制之前对列数据进行一些操作：对于每个列，它应用 WorksheetFunction.Sum() ，但您可以将其替换为您要使用的任何其他聚合函数 . 然后它将结果(每张一行)复制到"totals"表 .

这两种解决方案都在工作簿中，您可以下载from this site . 使用，运行宏，并从显示的选项列表中选择适当的宏 . 您可以通过调用VBA编辑器来编辑代码 .

Sub aggregateRaw()

Dim thisSheet, newSheet As Worksheet

Dim sheetCount As Integer

Dim targetRange As Range

sheetCount = ActiveWorkbook.Sheets.Count

' add a new sheet at the end:

If Not worksheetExists("totals") Then

Set newSheet = ActiveWorkbook.Sheets.Add(after:=Sheets(sheetCount))

newSheet.Name = "totals"

Else

Set newSheet = ActiveWorkbook.Sheets("totals")

End If

Set targetRange = newSheet.[A1]

' if you want to clear the sheet before copying data, uncomment this line:

' newSheet.UsedRange.Delete

' assuming you want to copy the headers, and that they are the same

' on all sheets, you can copy them to the "totals" sheet like this:

ActiveWorkbook.Sheets(1).Range("1:1").Copy targetRange

Set targetRange = targetRange.Offset(1, 0) ' down a row

' copy blocks of data from A2 to Q33 into the "totals" sheet

For Each ws In ActiveWorkbook.Worksheets

If ws.Name <> newSheet.Name Then

ws.Range("A2", "Q33").Copy targetRange

Set targetRange = targetRange.Offset(32, 0) ' down 32 rows

End If

Next ws

End Sub

Sub aggregateTotal()

Dim thisSheet, newSheet As Worksheet

Dim sheetCount As Integer

Dim targetRange As Range

Dim columnToSum As Range

sheetCount = ActiveWorkbook.Sheets.Count

' add a new sheet at the end:

If Not worksheetExists("totals") Then

Set newSheet = ActiveWorkbook.Sheets.Add(after:=Sheets(sheetCount))

newSheet.Name = "totals"

Else

Set newSheet = Sheets("totals")

End If

' assuming you want to copy the headers, and that they are the same

' on all sheets, you can copy them to the "totals" sheet like this:

Set targetRange = newSheet.[A1]

ActiveWorkbook.Sheets(1).Range("A1:Q1").Copy targetRange

Set targetRange = targetRange.Offset(1, 0) ' down a row

For Each ws In ActiveWorkbook.Worksheets

' don't copy data from "total" sheet to "total" sheet...

If ws.Name <> newSheet.Name Then

' copy the month label

ws.[A2].Copy targetRange

' get the sum of the coluns:

Set columnToSum = ws.[B2:B33]

For colNum = 2 To 17 ' B to Q

targetRange.Offset(0, colNum - 1).Value = WorksheetFunction.Sum(columnToSum.Offset(0, colNum - 2))

Next colNum

Set targetRange = targetRange.Offset(1, 0) ' next row in output

End If

Next ws

End Sub

Function worksheetExists(wsName)

' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html

worksheetExists = False

On Error Resume Next

worksheetExists = (Sheets(wsName).Name <> "")

On Error GoTo 0

End Function

Final(?) edit: 如果希望每次有人对工作簿进行更改时都自动运行此脚本，则可以通过向工作簿添加代码来捕获 SheetChange 事件 . 你这样做如下：

打开Visual Basic编辑器()

在项目浏览器(屏幕左侧)中，展开VBAProject

右键单击"ThisWorkbook"，然后选择"View Code"

在打开的窗口中，复制/粘贴以下代码行：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

' handle errors gracefully:

On Error GoTo errorHandler

' turn off screen updating - no annoying "flashing"

Application.ScreenUpdating = False

' don't respond to events while we are updating:

Application.EnableEvents = False

' run the same sub as before:

aggregateRaw

' turn screen updating on again:

Application.ScreenUpdating = True

' turn event handling on again:

Application.EnableEvents = True

Exit Sub ' if we encountered no errors, we are now done.

errorHandler:

Application.EnableEvents = True

Application.ScreenUpdating = True

' you could add other code here... for example by uncommenting the next two lines

' MsgBox "Something is wrong ... " & Err.Description

' Err.Clear

End Sub