【应用场景】
1. excel导出项目及对应的分期,楼栋的各个产品类型对应的各个面积指标数据,
分项目/分期/楼栋三个SHEET页签。当用户在楼栋层级编辑完产品类型对应的面积指标时,可以
通过宏函数自下往上先汇总到相同产品类型+面积指标的分期层级,再自动汇总到项目层级面积指标。
2. 用户填报完excel数据后,点击【面积签入】按钮,通过宏函数自动触发接口对应的RFC函数,走对应的K2/OA审批流程。
【前置条件】
excel启用宏
【代码实现】
1. 注册工作薄打开事件
sheet保护密码设置等
'注册工作薄打开事件
Private Sub Workbook_Open()
Let ProtectPassword = "77777"
'撤销保护使用的sheet
ProjectSheet.Unprotect ProtectPassword
BuildingSheet.Unprotect ProtectPassword
StageSheet.Unprotect ProtectPassword
'设置字体
ProjectSheet.Columns("a:z").Font.Name = "微软雅黑"
StageSheet.Columns("a:z").Font.Name = "微软雅黑"
BuildingSheet.Columns("a:z").Font.Name = "微软雅黑"
'隐藏列
StageSheet.Columns("AA:AN").EntireColumn.Hidden = True
BuildingSheet.Columns("AA:AN").EntireColumn.Hidden = True
ProjectSheet.Columns("AA:AN").EntireColumn.Hidden = True
ProjectSheet.Columns("AO:AT").EntireColumn.Hidden = True
StageSheet.Columns("AO:AT").EntireColumn.Hidden = True
BuildingSheet.Columns("AO:AT").EntireColumn.Hidden = True
'设置项目sheet版本信息锁定
ProjectSheet.Range("A2:L5").Locked = True
'设置单元格数据有效性
Call clsBusiness.SetCellValidation
'锁定单元格
If ProjectSheet.Range("C5").Value = "1" Then
'modify by 20210719:新增6个标签页---begin
'清除未使用单元格样式
ProjectSheet.Range("A" & CDbl(ProjectSheet.Range("A5").Value) + 8 & ":Q" & ProjectSheet.UsedRange.Rows.Count + 1).ClearFormats
StageSheet.Range("A" & CDbl(StageSheet.Range("A6").Value) + 8 & ":X" & StageSheet.UsedRange.Rows.Count + 1).ClearFormats
BuildingSheet.Range("A" & CDbl(BuildingSheet.Range("A5").Value) + 8 & ":V" & BuildingSheet.UsedRange.Rows.Count + 5).ClearFormats
'modify by at 20210719:新增6个标签页---end
'当楼栋个数为0时
If BuildingSheet.Range("A5").Value = "0" Then
BuildingSheet.Visible = xlSheetHidden
StageSheet.Unprotect ProtectPassword
'StageSheet.Range("F8:T" & CDbl(StageSheet.Range("A6").Value) + 7).Locked = False
StageSheet.Range("J8:X" & CDbl(StageSheet.Range("A6").Value) + 7).Locked = False 'modify by at 20210719:新增6个标签页
Else
BuildingSheet.Range("C8:C" & BuildingSheet.Range("A5").Value + 7).Locked = False
'BuildingSheet.Range("G8:Q" & BuildingSheet.Range("A5").Value + 7).Locked = False
BuildingSheet.Range("K8:U" & BuildingSheet.Range("A5").Value + 7).Locked = False 'modify by at 20210719:新增6个标签页
'根据分期下是否有楼栋来锁定单元格
Dim row_buid As Integer
For row_buid = 8 To CDbl(StageSheet.Range("A6").Value) + 7
If (StageSheet.Range("AF" & row_buid).Value = "1") Then
'StageSheet.Range("J" & row_buid & ":T" & row_buid).Interior.Color = StageSheet.Range("A8").Interior.Color
StageSheet.Range("N" & row_buid & ":X" & row_buid).Interior.Color = StageSheet.Range("A8").Interior.Color 'modify by c-zhabl01 at 20210719:新增6个标签页
'StageSheet.Range("J" & row_buid & ":T" & row_buid).Locked = True
StageSheet.Range("N" & row_buid & ":X" & row_buid).Locked = True 'modify by c-zhabl01 at 20210719:新增6个标签页
Else
'modify by c-zhabl01 at 20210719:新增6个标签页---begin
'StageSheet.Range("J" & row_buid & ":T" & row_buid).Interior.Color = StageSheet.Range("F" & row_buid).Interior.Color
'StageSheet.Range("J" & row_buid & ":T" & row_buid).Locked = False
StageSheet.Range("N" & row_buid & ":X" & row_buid).Interior.Color = StageSheet.Range("F" & row_buid).Interior.Color
StageSheet.Range("N" & row_buid & ":X" & row_buid).Locked = False
'modify by c-zhabl01 at 20210719:新增6个标签页---end
End If
Next row_buid
End If
'当分期个数为0
If StageSheet.Range("A6").Value = "0" Then
'ProjectSheet.Range("D8:N" & ProjectSheet.Range("A5").Value + 7).Locked = False
ProjectSheet.Range("G8:Q" & ProjectSheet.Range("A5").Value + 7).Locked = False 'modify by c-zhabl01 at 20210719:新增6个标签页
StageSheet.Visible = xlSheetHidden
Else
'modify by c-zhabl01 at 20210719:新增6个标签页---begin
' ProjectSheet.Range("D8:N" & ProjectSheet.Range("A5").Value + 7).Interior.Color = ProjectSheet.Range("A8").Interior.Color
' StageSheet.Range("F8:K" & StageSheet.Range("A6").Value + 7).Locked = False
ProjectSheet.Range("G8:Q" & ProjectSheet.Range("A5").Value + 7).Interior.Color = ProjectSheet.Range("A8").Interior.Color
StageSheet.Range("J8:O" & StageSheet.Range("A6").Value + 7).Locked = False
'modify by c-zhabl01 at 20210719:新增6个标签页---end
End If
End If
'add by james 2018/06/25 物流开发有些字段不能输入
If ProjectSheet.Range("AB5") = "Z010" Then
'modify by c-zhabl01 at 20210719:新增6个标签页---begin
' ProjectSheet.Range("I8:J" & ProjectSheet.Range("A5").Value + 7).Interior.Color = ProjectSheet.Range("A8").Interior.Color
' ProjectSheet.Range("I8:J" & ProjectSheet.Range("A5").Value + 7).Locked = True
' StageSheet.Range("K8:L" & StageSheet.Range("A6").Value + 7).Interior.Color = StageSheet.Range("A8").Interior.Color
' StageSheet.Range("K8:L" & StageSheet.Range("A6").Value + 7).Locked = True
' StageSheet.Range("O8:P" & StageSheet.Range("A6").Value + 7).Interior.Color = StageSheet.Range("A8").Interior.Color
' StageSheet.Range("O8:P" & StageSheet.Range("A6").Value + 7).Locked = True
' BuildingSheet.Range("H8:I" & BuildingSheet.Range("A5").Value + 7).Interior.Color = BuildingSheet.Range("A8").Interior.Color
' BuildingSheet.Range("H8:I" & BuildingSheet.Range("A5").Value + 7).Locked = True
' BuildingSheet.Range("L8:M" & BuildingSheet.Range("A5").Value + 7).Interior.Color = BuildingSheet.Range("A8").Interior.Color
' BuildingSheet.Range("L8:M" & BuildingSheet.Range("A5").Value + 7).Locked = True
ProjectSheet.Range("L8:M" & ProjectSheet.Range("A5").Value + 7).Interior.Color = ProjectSheet.Range("A8").Interior.Color
ProjectSheet.Range("L8:M" & ProjectSheet.Range("A5").Value + 7).Locked = True
StageSheet.Range("O8:Q" & StageSheet.Range("A6").Value + 7).Interior.Color = StageSheet.Range("A8").Interior.Color
StageSheet.Range("O8:Q" & StageSheet.Range("A6").Value + 7).Locked = True
StageSheet.Range("S8:T" & StageSheet.Range("A6").Value + 7).Interior.Color = StageSheet.Range("A8").Interior.Color
StageSheet.Range("S8:T" & StageSheet.Range("A6").Value + 7).Locked = True
BuildingSheet.Range("L8:M" & BuildingSheet.Range("A5").Value + 7).Interior.Color = BuildingSheet.Range("A8").Interior.Color
BuildingSheet.Range("L8:M" & BuildingSheet.Range("A5").Value + 7).Locked = True
BuildingSheet.Range("P8:R" & BuildingSheet.Range("A5").Value + 7).Interior.Color = BuildingSheet.Range("A8").Interior.Color
BuildingSheet.Range("P8:R" & BuildingSheet.Range("A5").Value + 7).Locked = True
'modify by c-zhabl01 at 20210719:新增6个标签页---end
End If
'按钮是否隐藏
If ProjectSheet.Range("B5").Value = "1" Then
ProjectSheet.Shapes.Range(Array("Picture 7")).Visible = msoTrue
ProjectSheet.Shapes.Range(Array("Picture 1")).Visible = msoTrue
ProjectSheet.Shapes.Range(Array("Picture 3")).Visible = msoTrue
StageSheet.Shapes.Range(Array("Picture 8")).Visible = msoTrue
StageSheet.Shapes.Range(Array("Picture 4")).Visible = msoTrue
StageSheet.Shapes.Range(Array("Picture 1")).Visible = msoTrue
BuildingSheet.Shapes.Range(Array("Picture 11")).Visible = msoTrue
BuildingSheet.Shapes.Range(Array("Picture 1")).Visible = msoTrue
BuildingSheet.Shapes.Range(Array("Picture 10")).Visible = msoTrue
'指定项目sheet图片按钮的宏
If ActiveSheet.CodeName = "ProjectSheet" Then
ActiveSheet.Shapes.Range(Array("Picture 7")).Select
Selection.OnAction = "SingIn"
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.OnAction = "SaveData"
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
Selection.OnAction = "StartApprove"
ActiveSheet.Range("G1").Select
End If
If ActiveSheet.CodeName = "StageSheet" Then
ActiveSheet.Shapes.Range(Array("Picture 8")).Select
Selection.OnAction = "SingIn"
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.OnAction = "SaveData"
ActiveSheet.Shapes.Range(Array("Picture 4")).Select
Selection.OnAction = "StartApprove"
ActiveSheet.Range("G1").Select
End If
If ActiveSheet.CodeName = "BuildingSheet" Then
ActiveSheet.Shapes.Range(Array("Picture 11")).Select
Selection.OnAction = "SingIn"
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.OnAction = "SaveData"
ActiveSheet.Shapes.Range(Array("Picture 10")).Select
Selection.OnAction = "StartApprove"
ActiveSheet.Range("G1").Select
End If
Else
ProjectSheet.Shapes.Range(Array("Picture 7")).Visible = msoFalse
ProjectSheet.Shapes.Range(Array("Picture 1")).Visible = msoFalse
ProjectSheet.Shapes.Range(Array("Picture 3")).Visible = msoFalse
StageSheet.Shapes.Range(Array("Picture 8")).Visible = msoFalse
StageSheet.Shapes.Range(Array("Picture 4")).Visible = msoFalse
StageSheet.Shapes.Range(Array("Picture 1")).Visible = msoFalse
BuildingSheet.Shapes.Range(Array("Picture 11")).Visible = msoFalse
BuildingSheet.Shapes.Range(Array("Picture 1")).Visible = msoFalse
BuildingSheet.Shapes.Range(Array("Picture 10")).Visible = msoFalse
End If
'设置第一行的行高
ProjectSheet.Rows("1:1").RowHeight = 32
StageSheet.Rows("1:1").RowHeight = 32
BuildingSheet.Rows("1:1").RowHeight = 32
'保护使用的heet
ProjectSheet.Protect ProtectPassword, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
StageSheet.Protect ProtectPassword, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
BuildingSheet.Protect ProtectPassword, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
End Sub
2. 楼栋填报模板宏函数实现
Private Sub Worksheet_Activate()
On Error GoTo err
BuildingSheet.Unprotect "1236777"
'指定图片按钮的宏
If ProjectSheet.Range("B5").Value = "1" Then
BuildingSheet.Shapes.Range(Array("Picture 11")).Select
Selection.OnAction = "SingIn"
BuildingSheet.Shapes.Range(Array("Picture 1")).Select
Selection.OnAction = "SaveData"
BuildingSheet.Shapes.Range(Array("Picture 10")).Select
Selection.OnAction = "StartApprove"
BuildingSheet.Range("G1").Select
End If
BuildingSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
'Dim res As String
'res = clsBase.GetBase64EncodeResul("v-tongj01:Football10")
Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbExclamation, "异常"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sinParkArea As Double '单个车位面积*
Dim row_buid As Integer
If Target.Column = 19 Then
row_buid = Target.Row
sinParkArea = CDbl(ProjectSheet.Range("G5").Value)
'车位可售面积
'If BuildingSheet.Range("AC" & row_buid).Value = "PC000028" And BuildingSheet.Range("M" & row_buid).Value <> "" And sinParkArea <> "0" And BuildingSheet.Range("AF" & row_buid).Value <> "03" Then
If BuildingSheet.Range("AC" & row_buid).Value = "PC000028" And BuildingSheet.Range("S" & row_buid).Value <> "" And sinParkArea <> "0" And BuildingSheet.Range("AF" & row_buid).Value <> "03" Then 'modify by C-ZHABL01 2021.07.19:新增6个标签页
'saleable_area = CDbl(BuildingSheet.Range("M" & row_buid).Value) * sinParkArea
saleable_area = CDbl(BuildingSheet.Range("S" & row_buid).Value) * sinParkArea 'modify by 2021.07.19:新增6个标签页
'BuildingSheet.Range("J" & row_buid).Value = saleable_area
BuildingSheet.Range("P" & row_buid).Value = saleable_area 'modify by 2021.07.19:新增6个标签页
End If
End If
' If change_times > 0 Then
' '如果楼栋数据不为空,则汇总到分期
' If BuildingSheet.Range("A5").Value <> "0" Then
' StageSheet.Unprotect "123698745@vk"
' '调用汇总分期数据函数
' Call clsBusiness.CopyBuildingdataToStage(8)
' StageSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
' End If
'
' '如果分期数据不为空,则汇总到项目
' If StageSheet.Range("A6").Value <> "0" Then
' '撤销保护使用的sheet
' ProjectSheet.Unprotect "123698745@vk"
' '调用汇项目期数据函数
' Call clsBusiness.CopyStagedataToProject(8)
' '保护使用的heet
' ProjectSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
'
' End If
' End If
change_times = change_times + 1
End Sub
3. 分期填报模板代码
Private Sub Worksheet_Activate()
On Error GoTo err
'关闭屏幕更新
Application.ScreenUpdating = False
'撤销保护使用的sheet
StageSheet.Unprotect "123698745@vk"
'如果楼栋数据不为空,则汇总到分期
If BuildingSheet.Range("A5").Value <> "0" Then
StageSheet.Unprotect "123698745@vk"
'调用汇总分期数据函数
Call clsBusiness.CopyBuildingdataToStage(8)
StageSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
End If
'指定图片按钮的宏
If ProjectSheet.Range("B5").Value = "1" Then
StageSheet.Shapes.Range(Array("Picture 8")).Select
Selection.OnAction = "SingIn"
StageSheet.Shapes.Range(Array("Picture 1")).Select
Selection.OnAction = "SaveData"
StageSheet.Shapes.Range(Array("Picture 4")).Select
Selection.OnAction = "StartApprove"
StageSheet.Range("G1").Select
End If
'保护使用的heet
StageSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
'开启屏幕更新
Application.ScreenUpdating = True
Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbExclamation, "异常"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
4. 项目填报模板
分期数据自动汇总到项目
'分期数据自动汇总到项目
Private Sub Worksheet_Activate()
On Error GoTo err
'关闭屏幕更新
Application.ScreenUpdating = False
'撤销保护使用的sheet
ProjectSheet.Unprotect "123698745@vk"
StageSheet.Unprotect "123698745@vk"
'modify by c-zhabl01 at 20210721:调整汇总的顺序,先汇总分期的,再汇总项目的---begin
' '如果分期数据不为空,则汇总到项目
' If StageSheet.Range("A6").Value <> "0" Then
' '调用汇项目期数据函数
' Call clsBusiness.CopyStagedataToProject(8)
' End If
' '如果楼栋数据不为空,则汇总到分期
' If BuildingSheet.Range("A5").Value <> "0" Then
' '调用汇总分期数据函数
' Call clsBusiness.CopyBuildingdataToStage(8)
' End If
'如果楼栋数据不为空,则汇总到分期
If BuildingSheet.Range("A5").Value <> "0" Then
'调用汇总分期数据函数
Call clsBusiness.CopyBuildingdataToStage(8)
End If
'如果分期数据不为空,则汇总到项目
If StageSheet.Range("A6").Value <> "0" Then
'调用汇项目期数据函数
Call clsBusiness.CopyStagedataToProject(8)
End If
'modify by c-zhabl01 at 20210721:调整汇总的顺序,先汇总分期的,再汇总项目的---end
'指定图片按钮的宏
If ProjectSheet.Range("B5").Value = "1" Then
ProjectSheet.Shapes.Range(Array("Picture 7")).Select
Selection.OnAction = "SingIn"
ProjectSheet.Shapes.Range(Array("Picture 1")).Select
Selection.OnAction = "SaveData"
ProjectSheet.Shapes.Range(Array("Picture 3")).Select
Selection.OnAction = "StartApprove"
ProjectSheet.Range("G1").Select
End If
'保护使用的heet
ProjectSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
StageSheet.Protect "123698745@vk", AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
'开启屏幕更新
Application.ScreenUpdating = True
Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbExclamation, "异常"
End Sub
5. CheckInput模块代码
验证填报的单元格数据完整性等
'验证楼栋数据完整性
Public Function checkBuildingInput(star_rowindex As Integer) As Boolean
'获取当前活动的sheet
Dim csheet As Worksheet
Set csheet = BuildingSheet
Dim Msg As String: Msg = "楼栋填报模板sheet:" & Chr(10)
Dim row_index As Integer
Dim col_index As Integer
Dim Result As Boolean: Result = True
Dim check_flag As String
'先显示所有列
Application.ScreenUpdating = False
'循环列
BuildingSheet.Unprotect "123698745@vk"
For col_index = 7 To 32
csheet.Cells(star_rowindex, col_index).EntireColumn.Hidden = False
Next col_index
Application.ScreenUpdating = True
BuildingSheet.Protect "123698745@vk"
If csheet.Range("A5").Value <> "0" Then
'循环行
For row_index = star_rowindex To CDbl(csheet.Range("A5").Value) + 7
'循环列
'For col_index = 7 To 14
For col_index = 11 To 19 'modify by suyinghui 2017.09.14
'除车位列外其他列均不能为空