文档章节

Vendor审核表

t
 tedzheng
发布于 2017/06/22 09:57
字数 829
阅读 12
收藏 0

原始表格如下:

控件: 一个List,个button

listbox1:获取行业类别,用以选择

button1->Generate:根据列表框选择的行业调整表格

button2->Rerverse: 展开所有表格

Process:

a. 表格打开时将行业读入列表框

Private Sub Workbook_Open()
Dim i&  '变量
    '初始化combobox
   With Sheet1
     .Activate
   ' .ListBox1.Select
     '位置
    .ListBox1.Left = 495
    .ListBox1.Top = 24
    .ListBox1.Height = 45
    .ListBox1.Width = 90
 End With
With Sheet1.ListBox1
   '删除旧的ITEM
   For i = .ListCount - 1 To 0 Step -1
     .RemoveItem (i)
   Next i
'添加新的ITEM
      For i = 6 To 15   '每6-14列
        .AddItem (Sheet1.Cells(4, i).Value)
      Next i
      '  .AddItem ("")   '增加空白ITEM,便于用户在EXCEL中选择数据
    End With
End Sub

b.Generate Button

Const BeginRow = 5
Const EndRow = 53
Const EndClm = 19
Const BaseClm = 5

Sub Generate_Rep()
Dim ListArr(1 To 10, 1 To 2), iArr&, cArr&    '存储获取listbox1的值
Dim iRow&, RowMark&          '行变量,隐藏标记0隐藏;>0显示
Dim CompArr(1 To 5) As Long, iComp&, CompMark&   '强制为0行号,记录器
Dim skTTL$                  '汇总行字段变量
Application.ScreenUpdating = False
'===================================================
'定义强制列
CompArr(1) = 6: CompArr(2) = 7: CompArr(3) = 8: CompArr(4) = 13
CompArr(5) = 21
'****************************************************
With Sheet1
'获取listbox1选中的值
cArr = 0        '多选框的计数项
For iArr = 0 To .ListBox1.ListCount - 1     '最后一行空值不取
    If .ListBox1.Selected(iArr) Then
      ListArr(iArr + 1, 1) = .ListBox1.List(iArr) '取值
      ListArr(iArr + 1, 2) = iArr + BaseClm + 1   '列号存于数组中
      cArr = cArr + 1 '选择计数项
    End If
Next
If cArr = 0 Then
   MsgBox ("Please select industrial type")
   Exit Sub
End If
'*****************************************************

    '隐藏未选择的列
    For iArr = 1 To UBound(ListArr)
       If ListArr(iArr, 1) = "" Then
        .Columns(iArr + BaseClm).EntireColumn.Hidden = True '隐藏列
       End If
    Next iArr
'*****************************************************
    '隐藏行
    For iRow = BeginRow To EndRow        '循环行
    '排除合计行
     RowMark = 0    '初始化
      For iArr = 1 To UBound(ListArr)   '循环列 6-15
        If ListArr(iArr, 1) <> "" Then  '排除隐藏行
           If .Cells(iRow, ListArr(iArr, 2)) <> "" Then
              RowMark = RowMark + 1
           End If
        End If
      Next iArr
    If RowMark > 0 Then
      .Rows(iRow).EntireRow.Hidden = False
    Else
      .Rows(iRow).EntireRow.Hidden = True
    End If
    Next iRow
'------------------------------------------------
    '不隐藏合计行,
    For iRow = BeginRow To EndRow        '循环行
        skTTL = .Cells(iRow, 1)          '汇总行
        If Check_Total_Line(skTTL) Then  '检查是否汇总行
            .Rows(iRow).EntireRow.Hidden = False   '取消隐藏
        End If
    Next iRow
'------------------------------------------------
    '6、7、8、13、21所处的U列一旦不得分,总分计零(强制性)
    CompMark = 0
    For iComp = 1 To UBound(CompArr)
       If .Rows(CompArr(iComp)).EntireRow.Hidden = False And .Cells(CompArr(iComp), 18) = 0 Then
         CompMark = CompMark + 1
       End If
    Next
    '公式
    If CompMark > 0 Then
       .Cells(2, EndClm) = 0
    Else
    .Cells(2, EndClm).FormulaR1C1 = "=SUM(R5C19:R53C19)"    '总得分公式
    End If
'*****************************************************
Application.ScreenUpdating = True
End With
MsgBox ("Generate Done")
End Sub

这里用到一个自定义函数Check_Total_Line,是用正则表达式和匹配小计行


'检查是否是汇总行
Function Check_Total_Line(ByVal Str$) As Boolean
Dim regx
Dim iMatches
Dim iCount
Set regx = CreateObject("vbscript.regexp")
    regx.Pattern = ".+\s+\d+\W"
    regx.Global = True
    Set iMatches = regx.Execute(Str)
    iCount = iMatches.Count
    If iCount > 0 Then
        Check_Total_Line = True
    Else
        Check_Total_Line = False
    End If
End Function

c. Reverse Butoon

'取消隐藏
Sub Reverse_Rep()
Dim nRev&, mRev&    '行,列变量
Dim iList&  '变量
Application.ScreenUpdating = False
With Sheet1

'取消listbox1的选择
For iList = 0 To .ListBox1.ListCount - 1
   If .ListBox1.Selected(iList) Then
      .ListBox1.Selected(iList) = False
   End If
Next iList
'取消列隐藏
For mRev = 1 To EndClm
   .Columns(mRev).EntireColumn.Hidden = False
   If mRev >= 6 And mRev <= 15 Then
      .Columns(mRev).ColumnWidth = 6.5       '设置列宽
   End If
Next mRev
'取消行隐藏
For nRev = 1 To EndRow
   .Rows(nRev).EntireRow.Hidden = False
Next nRev

Application.ScreenUpdating = True
End With
MsgBox ("Reverse Done")
End Sub

具体文件可以从我的网盘下载,文件名是->SHE供应商审核.xlsm

http://pan.baidu.com/s/1qYtz0Tm

仅供学习之用

© 著作权归作者所有

t
粉丝 2
博文 85
码字总数 47581
作品 0
奉贤
程序员
私信 提问
iOS9 获取手机的唯一标识(一)——CFUUID、NSUUID、IDFA、IDFV、UDID、OpenUDID 的区别

转自 http://my.oschina.net/hejunbinlan/blog/496724?p=1 在2013年3月21日苹果已经通知开发者,从2013年5月1日起,访问UIDID的应用将不再能通过审核,替代的方案是开发者应该使用“在iOS 6...

ziyuzhiye
2017/10/26
0
0
在Entity Framework 中执行T-sql语句

从Entity Framework 4开始在ObjectContext对象上提供了2个方法可以直接执行SQL语句:ExecuteStoreQuery<T> 和 ExecuteStoreCommand。 1、使用ExecuteStoreQuery<T> :通过sql查询返回object实......

Yamazaki
2013/08/27
529
0
众包找人模块

找人流程[@郭友军 负责发布步骤,其它步骤由@梁森 负责] 发布找人项目 发布有两步,第一步填写项目基本信息,第二步填写用人协议(我们提供默认内容)。 审核 管理员审核,并选择该项目的找人...

英强
2015/11/10
9
0
典型的版本回退设计问题

现实工作中,我们常常会遇到版本回退问题,比如有一个商品修改后通过审核,审核通过替换到新的版本,审核拒绝回退到旧的版本;以前我的想法是:两个表,一个表(editorgoods)存编辑状态的数...

anlen_gzz
2016/12/08
16
0
Yearning v1.1.2 更新,SQL 审核自动化平台  

Yearning SQL 审核平台 v1.1.2 版本发布。 具体更新内容如下: 新增权限申请 审核功能。权限可由用户自己申请并由超级管理员批准 修复sql过长导致样式异常的问题 调整导航栏布局 新增审核栏 ...

cookieY
2018/05/08
1K
4

没有更多内容

加载失败,请刷新页面

加载更多

Dubbo-自适应拓展机制

背景 在 Dubbo 中,很多拓展都是通过 SPI 机制进行加载的,比如 Protocol、Cluster、LoadBalance 等,这些都是Dubbo的基础组件。这些基础组件的拓展不是在系统框架启动阶段被加载,而是拓展方...

rock-man
21分钟前
5
0
Kali安装fcitx输入法(五笔)

安装fcitx > sudo apt-get install fcitx-rime fcitx-config-gtk3 重启 > sudo reboot fcitx配置 效果就是这样 配置输入法切换 系统设置...

yeahlife
22分钟前
3
0
IE之css3效果兼容

本文转载于:专业的前端网站▷IE之css3效果兼容 一、兼容css阴影效果(ie滤镜) 1.Shadow,阴影 .shadow { -moz-box-shadow: 3px 3px 4px #000; -webkit-box-shadow: 3px 3px 4px #000; box-sha...

前端老手
25分钟前
3
0
NiushopB2C开源商城功能列表说明:

B2C单商户免费版:PC商城+微商城 B2C单商户标准版:PC商城+微商城组合套餐+阶梯优惠核销功能 B2C单商户企业版:PC商城+微商城拼团+组合套餐阶梯优惠+核销功能 B2C单商户分销版:PC商城+微商城...

niushop-芳
27分钟前
3
0
图片如何转GIF图片呢

如何将生活中拍摄的好玩有趣的图片制作成GIF动图呢?相信很多小伙伴都不知道要如何制作,其实制作方法非常的简单,下面分享一个图片转GIF动图的方法,希望这个方法能够帮助大家在与好友斗图时...

白米稀饭2019
34分钟前
3
0

没有更多内容

加载失败,请刷新页面

加载更多

返回顶部
顶部