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