20180830xlVBA_合并计算
Sub WorkbooksSheetsConsolidate()
Rem 设置求和区域为 sheet名称/单元格区域;sheet名称/单元格区域
Const Setting As String = "Sheet1/A1:G6;Sheet1/A8:E8;Sheet1/F8:G8;Sheet2/A1:G3;Sheet2/A5:G5"
Const FOLDER_NAME As String = "文件夹"
Dim StartTime As Variant
Dim UsedTime As Variant
StartTime = VBA.Timer AppSettings True
Dim Wb As Workbook
Dim Sht As Worksheet
Dim Dic As Object
Dim Key As String
Dim OneKey
Dim Brr
Dim Arr As Variant
Dim Rng As Range
Dim FilePaths, FilePath
Dim FolderPath As String
Dim OpenWb As Workbook
Dim OpenSht As Worksheet Set Dic = CreateObject("Scripting.Dictionary")
Set Wb = Application.ThisWorkbook
FolderPath = Wb.Path & "\" & FOLDER_NAME & "\" Dim SheetName, RngAddress
Dim Areas, OneArea
Areas = Split(Setting, ";")
For Each OneArea In Areas
SheetName = Split(OneArea, "/")(0)
RngAddress = Split(OneArea, "/")(1)
'解析地址 初始化数组
On Error Resume Next
Set Sht = Wb.Worksheets(SheetName)
If Err.Number = 9 Then
MsgBox "当前工作簿不存在名为【" & SheetName & "】的工作簿!", vbInformation, "Information"
GoTo ErrorExit
End If
On Error GoTo 0 Set Rng = Sht.Range(RngAddress)
Rng.ClearContents
Arr = Rng.Value
Debug.Print SheetName; " "; RngAddress
Do
If Dic.Exists(SheetName) = False Then Exit Do
SheetName = SheetName & "@"
Loop
Dic(SheetName) = Array(RngAddress, Arr) Next OneArea FilePaths = FsoGetFiles(FolderPath, "*.xls*")
If FilePaths(1) = "None" Then
MsgBox "指定文件夹未找到任何工作簿!", vbInformation, "Information"
GoTo ErrorExit
End If For Each FilePath In FilePaths
Set OpenWb = Application.Workbooks.Open(FilePath)
For Each OneKey In Dic.Keys
SheetName = Replace(OneKey, "@", "")
On Error Resume Next
Set OpenSht = OpenWb.Worksheets(SheetName)
If Err.Number = 9 Then
MsgBox "打开工作簿不存在名为【" & SheetName & "】的工作簿!", vbInformation, "Information"
OpenWb.Close False
GoTo ErrorExit
End If
On Error GoTo 0 Ar = Dic(OneKey)
RngAddress = Ar(0)
Arr = Ar(1) Set Rng = OpenSht.Range(RngAddress)
Brr = Rng.Value For i = LBound(Arr) To UBound(Arr)
For j = LBound(Arr, 2) To UBound(Arr, 2)
If IsNumeric(Brr(i, j)) Then
'只有为数字时才可以相加
Arr(i, j) = Arr(i, j) + Brr(i, j)
Else
MsgBox "工作簿:" & FilePath & vbCr & _
"工作表:" & SheetName & vbCr & _
"单元格:" & Rng.Cells(i, j).Address & "的数据不是数字,不能累加"
GoTo ErrorExit
End If
Next j
Next i '更新求和数据
Ar(1) = Arr
Dic(OneKey) = Ar
Next OneKey
OpenWb.Close False
Next FilePath For Each OneKey In Dic.Keys
SheetName = Replace(OneKey, "@", "")
Ar = Dic(OneKey)
RngAddress = Ar(0)
Arr = Ar(1)
Set Sht = Wb.Worksheets(SheetName)
Set Rng = Sht.Range(RngAddress)
Rng.Value = Arr
Next OneKey UsedTime = VBA.Timer - StartTime
Debug.Print "UsedTime :" & Format(UsedTime, "#0.0000 Seconds")
'MsgBox "UsedTime :" & Format(UsedTime, "#0.0000 Seconds") ErrorExit:
Set Dic = Nothing
Set Wb = Nothing
Set Sht = Nothing
Set Rng = Nothing
Set OpenWb = Nothing
Set OpenSht = Nothing
Erase Arr
Erase Brr
Erase Ar
AppSettings False
End Sub
Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
Dim Arr() As String
Dim FSO As Object
Dim ThisFolder As Object
Dim OneFile As Object
ReDim Arr(1 To 1)
Arr(1) = "None"
Dim Index As Long
Index = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo ErrorExit
Set ThisFolder = FSO.getfolder(FolderPath)
If Err.Number <> 0 Then Exit Function
For Each OneFile In ThisFolder.Files
If OneFile.Name Like Pattern Then
If Len(ComplementPattern) > 0 Then
If Not OneFile.Name Like ComplementPattern Then
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path
End If
Else
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path
End If
End If
Next OneFile
ErrorExit:
FsoGetFiles = Arr
Erase Arr
Set FSO = Nothing
Set ThisFolder = Nothing
Set OneFile = Nothing
End Function
Sub AppSettings(Optional IsStart As Boolean = True)
Application.ScreenUpdating = IIf(IsStart, False, True)
Application.DisplayAlerts = IIf(IsStart, False, True)
Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)
Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)
End Sub
20180830xlVBA_合并计算的更多相关文章
- 20161227xlVBA多文件合并计算
Sub NextSeven_CodeFrame() '应用程序设置 Application.ScreenUpdating = False Application.DisplayAlerts = Fal ...
- Excel合并计算
office版本为2013,数据来源:我要自学网,曾贤志老师 计算之前,光标定在空白位置,不要定在数据源. 将汇总的类型居于首列(不可以跨区域选择,可以把不需要汇总的移动到其他列). 要有删除原来数据 ...
- iOS tableView 数据处理,数据分类相同数据整合、合并计算总数总价
// 数据下载得到数组数据 modelArray = [MZPriceModel mj_objectArrayWithKeyValuesArray:data[@"info"]]; ...
- Java的几个同步辅助类
Java为我们提供了一些同步辅助类,利用这些辅助类我们可以在多线程编程中,灵活地把握线程的状态. CountDownLatch CountDownLatch一个同步辅助类,在完成一组正在其他线程中执行 ...
- CSS3与页面布局学习总结(二)——Box Model、边距折叠、内联与块标签、CSSReset
一.盒子模型(Box Model) 盒子模型也有人称为框模型,HTML中的多数元素都会在浏览器中生成一个矩形的区域,每个区域包含四个组成部分,从外向内依次是:外边距(Margin).边框(Border ...
- java多线程--同步屏障CyclicBarrier的使用
CyclicBarrier的概念理解: CyclicBarrier的字面上的意思是可循环的屏障,是java并发包java.util.concurrent 里的一个同步工具类,在我下载的JDK1.6的中 ...
- 【分布式】Zookeeper应用场景
一.前言 在上一篇博客已经介绍了Zookeeper开源客户端的简单实用,本篇讲解Zookeeper的应用场景. 二.典型应用场景 Zookeeper是一个高可用的分布式数据管理和协调框架,并且能够很好 ...
- 【干货分享】前端面试知识点锦集02(CSS篇)——附答案
二.CSS部分 1.解释一下CSS的盒子模型? 回答一:a.标准的css盒子模型:宽度=内容的宽度+边框的宽度+加上内边具的宽度b.网页设计中常听的属性名:内容(content).填充(padding ...
- 探索C#之微型MapReduce
MapReduce近几年比较热的分布式计算编程模型,以C#为例简单介绍下MapReduce分布式计算. 阅读目录 背景 Map实现 Reduce实现 支持分布式 总结 背景 某平行世界程序猿小张接到B ...
随机推荐
- centos6.8下如何升级git版本?
1. 安装开发环境 yum install -y curl curl-devel zlib-devel openssl-devel perl cpio expat-devel gettext-deve ...
- JWT、OAUTH2与SSO资料补充
JWT: 阮一峰:http://www.ruanyifeng.com/blog/2018/07/json_web_token-tutorial.html https://blog.csdn.net/q ...
- Perceptual Losses for Real-Time Style Transfer and Super-Resolution and Super-Resolution 论文笔记
Perceptual Losses for Real-Time Style Transfer and Super-Resolution and Super-Resolution 论文笔记 ECCV 2 ...
- HDU 1251 统计难题(字典树模板题)
http://acm.hdu.edu.cn/showproblem.php?pid=1251 题意:给出一些单词,然后有多次询问,每次输出以该单词为前缀的单词的数量. 思路: 字典树入门题. #inc ...
- 理解 Redis(4) - 关于 string 的更多命令(SETEX, SETNX, INCR, DECR, MSET...)
上一节介绍了关于字符串值的一些基本命令, 这一节将介绍一些进阶命令: 清理终端: 127.0.0.1:6379> clear 设置一个键值对, 同时设置过期时间为10秒: 127.0.0.1:6 ...
- 蚂蚁金服“定损宝”现身AI顶级会议NeurIPS
小蚂蚁说: 长期以来,车险定损(通过现场拍摄定损照片确定车辆损失,以作为保险公司理赔的依据)是车险理赔中最为重要的操作环节.以往传统保险公司的车险处理流程,一般为报案.现场查勘.提交理赔材料.审核.最 ...
- JTopo使用心得
因为工作关系,最近用到了拓扑图,找了一溜工具后,发现了这个--JTopo,纯国产而且免费 当然了如果你英文水平足够好的话.也可以看看这些英文的做拓扑图的工具,以下网站出自知乎回答:开源HTML5 绘图 ...
- Centos7安装JDK8以及环境配置
下载,选择centos7 64位版本 https://www.oracle.com/technetwork/java/javase/downloads/jdk8-downloads-2133151.h ...
- python连接MongoDB(有密码有认证)
from pymongo import MongoClient host = '127.0.0.1' client = MongoClient(host, ) #连接mydb数据库,账号密码认证 db ...
- php 中 public private protected的区别
public 子类,外部都可调用. protected 子类可以调用,外部不可以调用. private 子类不可以调用,外部不可以调用. <?php class AA { public func ...