20170622xlVBA多部门分类汇总同类合并单元格
Public Sub Basic_CodeFrame()
AppSettings
On Error GoTo ErrHandler
Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'Input code here Call SubTotalData UsedTime = VBA.Timer - StartTime
'Debug.Print "UsedTime:" & Format(UsedTime, "0.000 Seconds")
MsgBox "UsedTime:" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "NS QQ "
ErrorExit:
AppSettings False
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "!", vbCritical, "NextSeven QQ "
Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
If IsStart Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
Else
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End If
End Sub Private Sub SubTotalData()
Dim dShtName As Object
Dim dInfo As Object
Dim Key As String
Dim OneKey
Const MAIN_SHEET As String = "分类汇总表"
Const SALE_SHEET As String = "销售数据汇总表"
Const PROC_SHEET As String = "生产入库明细表"
Const STORE_SHEET As String = "汇总后库存明细表"
Const HEAD_ROW As Long = 3
Const END_COL As String = "Z"
Dim EndRow As Long
Dim Wb As Workbook Dim Sht As Worksheet
Dim oSht As Worksheet
Dim Rng As Range
Dim Arr As Variant
Dim Data() As Variant Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets(MAIN_SHEET) Set dShtName = CreateObject("Scripting.Dictionary")
Set dInfo = CreateObject("Scripting.Dictionary") Key = MAIN_SHEET
dShtName(Key) = "" Key = SALE_SHEET
dShtName(Key) = "" Key = PROC_SHEET
dShtName(Key) = "" Key = STORE_SHEET
dShtName(Key) = "" For Each oSht In Wb.Worksheets
If dShtName.EXISTS(oSht.Name) = False Then
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i, 3))
Item = CStr(Arr(i, 3)) & ";" & CStr(Arr(i, 4)) & _
";" & CStr(Arr(i, 5)) & ";" & CStr(Arr(i, 6))
'Debug.Print Item
dInfo(Key) = Item
Next i
End With
End If
Next oSht ReDim Data(1 To 14, 1 To 1)
Dim Index As Long
Dim PlanIndex As Long
Dim SaleIndex As Long
Dim ProcIndex As Long
Dim StoreIndex As Long Index = 0
PlanIndex = Index
SaleIndex = Index
ProcIndex = Index
StoreIndex = Index For Each OneKey In dInfo.keys
Key = OneKey
'循环所有部门工作表
For Each oSht In Wb.Worksheets
If dShtName.EXISTS(oSht.Name) = False Then
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 3)) = Key Then
PlanIndex = PlanIndex + 1 '计划生产部分 ReDim Preserve Data(1 To 14, 1 To PlanIndex)
info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, PlanIndex) = info(n)
Next n
Data(5, PlanIndex) = Format(Arr(i, 1), "yyyy/mm/dd") '日期
Data(6, PlanIndex) = Arr(i, 8)
Data(7, PlanIndex) = Arr(i, 2)
End If
Next i
End With
End If
Next oSht Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
Set oSht = Wb.Worksheets(PROC_SHEET)
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 15)) = Key Then
ProcIndex = ProcIndex + 1 '计划生产部分
'重定义数组
If ProcIndex > Index Then ReDim Preserve Data(1 To 14, 1 To ProcIndex) info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, ProcIndex) = info(n)
Next n Data(8, ProcIndex) = Format(Arr(i, 4), "yyyy/mm/dd") '日期
Data(9, ProcIndex) = Arr(i, 19)
Data(10, ProcIndex) = Arr(i, 13)
End If
Next i
End With Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
Set oSht = Wb.Worksheets(SALE_SHEET)
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 17)) = Key Then
SaleIndex = SaleIndex + 1 '计划生产部分
'重定义数组
If SaleIndex > Index Then ReDim Preserve Data(1 To 14, 1 To SaleIndex)
info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, SaleIndex) = info(n)
Next n
Data(11, SaleIndex) = Arr(i, 6)
Data(12, SaleIndex) = Arr(i, 21) End If
Next i
End With Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
Set oSht = Wb.Worksheets(STORE_SHEET)
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 2)) = Key Then
StoreIndex = StoreIndex + 1 '计划生产部分
'重定义数组
If StoreIndex > Index Then ReDim Preserve Data(1 To 14, 1 To StoreIndex)
info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, StoreIndex) = info(n)
Next n Data(13, StoreIndex) = Arr(i, 6)
Data(14, StoreIndex) = Format(Arr(i, 4), "yyyy/mm/dd") End If
Next i
End With '再次初始化
Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
PlanIndex = Index
SaleIndex = Index
ProcIndex = Index
StoreIndex = Index Next OneKey Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) With Sht
.UsedRange.Offset(2).Clear
Set Rng = .Range("A3").Resize(Index, 14)
Rng.Value = Application.WorksheetFunction.Transpose(Data) '输出数组
MergeSameItem .UsedRange '合并同项
SetEdges .UsedRange '设置居中与边框
End With End Sub
Private Sub MergeSameItem(ByVal RngWithTitle As Range)
'禁止合并单元格过程中出现警告提示
Application.DisplayAlerts = False
Dim i As Integer
Dim RowCount As Long
Dim LastRow As Long
Dim FirstRow As Long
With RngWithTitle
'根据A列序号合并A列
RowCount = .Cells.Rows.Count
LastRow = RowCount For i = RowCount To 2 Step -1
If .Cells(i, "A").Value <> .Cells(i - 1, "A").Value Then '若前后行内容不同
FirstRow = i '记下合并区域的起始行 .Cells(FirstRow, "A").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
.Cells(FirstRow, "B").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
.Cells(FirstRow, "C").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
.Cells(FirstRow, "D").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区 LastRow = i - 1 '调整下一个区域的终止行
End If
Next i End With
Application.DisplayAlerts = True '恢复警告提示
End Sub
Private Sub SetEdges(ByVal Rng As Range)
With Rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
If .Cells.Count > 1 Then
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
End With
End Sub
20170622xlVBA多部门分类汇总同类合并单元格的更多相关文章
- DataTables合并单元格(rowspan)的实现思路(多分组分类的情况)
直接上代码,原理之前的随笔已经讲过了.http://www.cnblogs.com/hdwang/p/7115835.html 1.先看看效果 2.html代码,含js代码 2.1 common.js ...
- postgresql高级应用之合并单元格
postgresql高级应用之合并单元格 转载请注明出处https://www.cnblogs.com/funnyzpc/p/14732172.html 1.写在前面✍ 继上一篇postgresql高 ...
- 【记录】解析具有合并单元格的Excel
最近公司让做各种数据表格的导入导出,就涉及到电子表格的解析,做了这么多天总结一下心得. 工具:NOPI 语言:C# 目的:因为涉及到导入到数据库,具有合并单元格的多行必然要拆分,而NPOI自动解析的时 ...
- poi excel 合并单元格
结论:final CellRangeAddress cra = new CellRangeAddress(rowId, rowId + rowSkip, colId, colId + c ...
- 【开发者笔记】解析具有合并单元格的Excel
最近公司让做各种数据表格的导入导出,就涉及到电子表格的解析,做了这么多天总结一下心得. 工具:NOPI 语言:C# 目的:因为涉及到导入到数据库,具有合并单元格的多行必然要拆分,而NPOI自动解析的时 ...
- npoi导出excel合并单元格
需要引用NPOI.dll程序集和Ionic.Zip.dll程序集 string[] headerRowName = { "序号", "地市", "镇街 ...
- react antd Table动态合并单元格
示例数据 原始数组 const data = [ { key: '0', name: 'John Brown', age:22, address: 'New York No. 1 Lake Park' ...
- java导出标题多行且合并单元格的EXCEL
场景:项目中遇到有需要导出Excel的需求,并且是多行标题且有合并单元格的,参考网上的文章,加上自己的理解,封装成了可自由扩展的导出工具 先上效果,再贴代码: 调用工具类进行导出: public st ...
- 导出excel带合并单元格方法的Demo
package com.test.util; import java.io.FileNotFoundException; import java.io.FileOutputStream; import ...
随机推荐
- SSRS创建复合型图表
SSRS创建复合型图表 1.添加报表数据对应代码: if object_id('tb') is not null drop table tb; go CREATE TABLE tb(yearid in ...
- 服务器返回的json数据中含有null的处理方法
个人博客:http://guohuaden.com/2017/03/06/json-dataNull/因为有遇到过类似情况,所以就想到了一些解决方法,并且实践了一下,这里简单的做个记录. 注:有看到不 ...
- Linux基础命令---ar
ar ar指令可以创建.修改库,也可以从库中提取单个模块.库是一个单独的文件,里面包含了按照特定结构组织起来的其他文件,我们称作member.归档文件通常是一个二进制文件,我们一般将归档文件当作库来使 ...
- MySQL Crash Course #09# Chapter 17. Combining Queries: UNION
INDEX UNION Rules WHERE VS. UNION UNION VS. UNION ALL Sorting Combined Query Results UNION Rules As ...
- centos6.7rsync端与window2012服务器实时文件同步
windows文件共享我就不截图了,估计大家都会,我就直接在centos6.7上操作了一.挂载win共享文件夹mount -t cifs -o username=administrator,passw ...
- VC++禁止标题栏鼠标双击事件
转载:http://blog.sina.com.cn/s/blog_4ad042e50102dwv0.html 重载DefWindowProc,在里面截获WM_NCLBUTTONDBLCLK消息进行处 ...
- Python3基础 break while循环示例
Python : 3.7.0 OS : Ubuntu 18.04.1 LTS IDE : PyCharm 2018.2.4 Conda ...
- Linux必备知识
一.Linux命令行常用快捷键 在企业工作中,管理Linux时—般不会直接采用键盘.显示器登录系统,而是会通过网络在远程进行管理,因此,需要通过远程连接具连接到Linux系统中.目前最常用的Linux ...
- 记录openwrt下补丁apply的过程中出错,但是可以单独打上该补丁
背景: 在openwrt的编译框架下无法正确打上补丁,而单独使用git却可以成功 这个补丁到底与其它补丁有何不同? 该补丁的生成的过程解析: 旧文件:vi 打开旧文件会提示no newline at ...
- ubuntu 安装 ftp服务
1. 更新源列表 ---> sudo apt-get update 2. 安装vsftpd ---> sudo apt-get install vsftpd (安装) ----> s ...