VBA综合应用——解压并剔除Excel敏感数据

作者：AntoniotheFuture

关键词：VBA，Excel自动化，办公自动化

开发平台：Excel2010

平台版本上限：2010

平台版本下限：尚未发现。

开发语言：VBA

简介：公司里有些同事每天都需要一些人员清单，但因为岗位性质和权限的不同，他们只能委托我们帮忙从系统中调取，我们也必须要将里面所含有的敏感信息剔除后（包括联系方式，收入等），才能给他们，而因为系统不完善等各种原因，我们从调取清单到发送给他们之前，需要花费一定的时间和精力，为了减少工作量，提高效率，我特意花了一点时间，开发了以下的一个小工具。

主要功能：

解压下载后的压缩包，读取里面的所有Excel文件，并将带有敏感信息的列删除，然后另存为新的Excel文件。

目前优缺点：

优点：

减少人工操作，提高工作效率。
使用Excel环境进行编译和运行，易接受性和可维护性高，使用者无需安装任何软件。
可以按使用者实际安装的压缩器来运行，不需另外安装。
默认保持为xlsb格式文件，大大减少了占用空间。
可以根据自己的要求预设关键词，而不是写死的关键词，便于业务拓展。

缺点：1、运行耗时稍长，需要优化代码。

改进点：

由于这是我早期的项目，没有使用到窗体，如果使用窗体，某些代码可以优化。

主要界面：

主界面，用于每次运行的设置。

设置界面，可以设置默认路径，输出格式和关键词等

主要核心代码：界面、表单代码可以根据自己的想法来写。

1、主过程：

'定义监听shell运行过程的函数，需要调用API：
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400Sub main()
'Code written by AntoniotheFuture at 2018-3-5
'Version:V1.0
'Function:打开或解压后打开Excel文件，并剔除表头带有特定关键字的列Dim format1 As XlFileFormat         '输出格式
Dim listc As Object                 'listbox
Dim Wb As Workbook                  '工作簿对象
Dim sh As Worksheet                 '工作表对象
Dim road, newname, xlfile          'road:原始路径,newname:新文件名,xlfile:缓存文件
Dim x, y, li, words, changes, i     '循环参数
Dim excel_App As Excel.Application  'Excel程序对象
Dim excel_Book As Excel.Workbook    '工作簿对象
Dim excel_sheet As Excel.Worksheet  '工作表对象
Dim Shellstring2 As String          '解压缩命令
Dim shellresult, runresult As String 'shell执行结果
Dim fs As Object                    '清空缓存目录
Dim pid As Long, PExit As Long  '监听shell变量Application.ScreenUpdating = False
Application.StatusBar = "检查参数...."'遍历控件并记录输出格式
For i = 1 To 5If Sheet2.OLEObjects("optionbutton" & i).Object.Value = True And i = 1 Thenformat1 = xlOpenXMLWorkbookformat2 = "xlsx"ElseIf Sheet2.OLEObjects("optionbutton" & i).Object.Value = True And i = 3 Thenformat1 = xlExcel12format2 = "xlsb"ElseIf Sheet2.OLEObjects("optionbutton" & i).Object.Value = True And i = 2 Thenformat1 = xlExcel8format2 = "xls"End If
Next'判断表单有效性If Sheet2.ListBox1.ListCount = 0 ThenMsgBox ("请选择文件!")Exit Sub
ElseIf Sheet2.maintextbox2 = "" Or Dir(Sheet2.maintextbox2, vbDirectory) = "" ThenMsgBox ("请选择正确的目标文件夹！")Exit Sub
ElseIf Sheet2.CheckBox1.Value = False And Sheet2.CheckBox2.Value = False And Sheet2.CheckBox3.Value = False And Sheet2.CheckBox4.Value = False ThenIf MsgBox("确认不剔除任何信息吗？", vbYesNo) = vbNo ThenExit SubEnd If
ElseIf Sheet2.CheckBox7.Value = True And Sheet2.TextBox2 = "" ThenMsgBox ("您已选择删除系统字符串，请在文本框内输入关键字！")Exit Sub
End If'检查设置（调用settingable函数，见后文）
settingable'新建Excel进程，用于处理文件
Set excel_App = CreateObject("Excel.Application")
excel_App.Visible = False
Set listc = Sheet2.ListBox1
changes = 0
Sheet2.ListBox3.Clear'清空缓存目录
Set fs = CreateObject("scripting.filesystemobject")
fs.deletefile Sheet1.TextBox5 & "\*.*"'遍历源文件并执行动作
For i = 1 To listc.ListCountroad = listc.List(i - 1)Debug.Print roadConst PINGSTART As Byte = 0Const PINGEND As Byte = 254Const PING_IP_IN_ONE_BAT As Long = 1'确定是否解压If road Like "*.xl*" ThenSheet2.ListBox3.AddItem roadElseApplication.StatusBar = "正在解压第" & i & "个文件：" & road'用7z解压缩到缓存目录If Sheet1.OptionButton1.Value = True Then'构造命令文本Shellstring2 = Sheet1.TextBox1 & " x " & Chr(34) & road & Chr(34) & " -o" & Chr(34) & Sheet1.TextBox5 & "\" & Chr(34) & " -aoa"Debug.Print Shellstring2'用shell执行命令并监听执行结果，获取结果后继续pid = Shell(Shellstring2, vbHide)pid = OpenProcess(PROCESS_QUERY_INFORMATION, False, pid)DoGetExitCodeProcess pid, PExitLoop While PExit = STILL_ACTIVE'用winrar解压缩到缓存目录ElseIf Sheet1.OptionButton2.Value = True ThenShellstring2 = Sheet1.TextBox2 & " x " & Chr(34) & road & Chr(34) & " -y " & Chr(34) & Sheet1.TextBox5 & "/" & Chr(34)Debug.Print Shellstring2pid = Shell(Shellstring2, vbHide)pid = OpenProcess(PROCESS_QUERY_INFORMATION, False, pid)DoGetExitCodeProcess pid, PExitLoop While PExit = STILL_ACTIVEElseMsgBox ("未选择压缩程序！")Sheet1.ActivateExit SubEnd IfEnd If
Next'遍历缓存文件夹
xlfile = Dir(Sheet1.TextBox5 & "\" & "*.xl*")
Do While xlfile <> ""Sheet2.ListBox3.AddItem Sheet1.TextBox5 & "\" & xlfilexlfile = Dir
Loop'确定运行参数
For i = 1 To Sheet2.ListBox3.ListCountroad = Sheet2.ListBox3.List(i - 1)Application.StatusBar = "正在扫描第" & i & "个文件：" & roadnewname = Split(road, "\")(UBound(Split(road, "\")))newname2 = Left(newname, InStr(newname, ".") - 1)If Sheet2.CheckBox7.Value = True And newname2 Like "*" & Sheet2.TextBox2 & "*" Thennewname2 = Left(newname2, InStr(newname2, Sheet2.TextBox2) - 1)End IfIf Sheet2.CheckBox6.Value = True Thennewname2 = newname2 & Format(Date, "yyyymmdd") & Format(Time, "hhmmss")End If'打开要处理的工作簿Set excel_Book = excel_App.Workbooks.Open(road, 0, True)'扫描工作表For Each sh In excel_Book.Sheets'扫描非空列For y = 1 To sh.UsedRange.Columns.Count'扫描行数For x = 1 To CLng(Sheet1.TextBox7)'读取控件参数For li = 1 To 4For words = 1 To Sheet1.OLEObjects("listbox" & li).Object.ListCount'关键词判断If InStr(sh.Cells(x, y), Sheet1.OLEObjects("listbox" & li).Object.List(words - 1)) Thensh.Columns(y).Deletey = y - 1changes = changes + 1GoTo exitloop1End IfNextNextNextApplication.StatusBar = "正在处理第" & i & "个文件：" & road
exitloop1:NextNext'生成新文件路径并保存Debug.Print Sheet2.maintextbox2 & "\" & newnameApplication.StatusBar = "正在保存第" & i & "个文件：" & roadexcel_App.DisplayAlerts = Falseexcel_Book.SaveAs Sheet2.maintextbox2 & "\" & newname2, format1excel_Book.Close Falseexcel_App.DisplayAlerts = TrueSet excel_Book = NothingSheet2.ListBox2.AddItem Sheet2.maintextbox2 & "\" & newname2 & "." & format2Sheet2.TextBox1 = Sheet2.TextBox1 & Chr(10) & road & "执行成功！"Application.StatusBar = "准备就绪"'判断是否打开新文件
If Sheet2.CheckBox5 = True ThenApplication.StatusBar = FalseWorkbooks.Open Sheet2.maintextbox2 & "\" & newname2 & "." & format2, 0, True
End If
nextchange:
NextMsgBox ("执行成功，剔除" & changes & "列数据")excel_App.Quit
Set excel_App = NothingExit Sub'错误事件
changeerror:
Sheet2.TextBox1 = Sheet2.TextBox1 & Chr(10) & road & "执行失败！"
GoTo nextchange
End Sub

2、计算缓存：

Sub cfoldersize()
'计算缓存占用量
Set fso = CreateObject("scripting.filesystemobject")
If Sheet1.TextBox5 = "" ThenMsgBox ("请在上方选择缓存文件夹！")Exit Sub
ElseIf Dir(Sheet1.TextBox5, vbDirectory) = "" ThenMsgBox ("缓存目录不存在，请重新设置缓存目录！")Sheet1.ActivateExit SubElseSet fld = fso.getfolder(Sheet1.TextBox5)Sheet1.Label16 = Format(fld.Size / 1024 / 1024, "0") & "MB"End If
End If
End Sub

3、初始化（用于保存或读取设置）

Sub 初始化()
Dim i, ii, x, y
Sheet2.maintextbox1 = Sheet1.TextBox3
Sheet2.maintextbox2 = Sheet1.TextBox4
cfoldersizeSheet2.TextBox1.Text = ""'遍历工作表并赋值到控件
For y = 1 To 4Sheet1.OLEObjects("listbox" & y).Object.ClearFor x = 2 To 100If Sheet3.Cells(x, y) <> "" ThenSheet1.OLEObjects("listbox" & y).Object.AddItem Sheet3.Cells(x, y)ElseExit ForEnd IfNext
Next'遍历控件并赋值到工作表
For y = 1 To 4For x = 1 To Sheet1.OLEObjects("listbox" & y).Object.ListCountSheet3.Cells(x + 1, y) = Sheet1.OLEObjects("listbox" & y).Object.List(x - 1)Debug.Print x & " " & yNext
Next'遍历默认设置并赋值到主界面
For y = 1 To 5If Sheet1.OLEObjects("optionbutton" & y + 2).Object.Value = True ThenSheet2.OLEObjects("optionbutton" & y).Object.Value = TrueEnd If
NextEnd Sub

4、检验设置

Sub settingable()
'检验设置参数可用性If Sheet1.OptionButton1.Value = True ThenIf Sheet1.TextBox1 <> "" And Dir(Sheet1.TextBox1, vbDirectory) <> "" ThenExit SubElseGoTo Error1End IfElseIf Sheet1.OptionButton2.Value = True ThenIf Sheet1.TextBox2 <> "" And Dir(Sheet1.TextBox2, vbDirectory) <> "" ThenExit SubElseGoTo Error1End IfElseExit SubEnd If
Error1:MsgBox ("请选择压缩程序及压缩程序路径")End Sub

5、清空缓存

Private Sub CommandButton6_Click()
Dim fs As Object
If Sheet1.TextBox5 = "" And Dir(Sheet1.TextBox5, vbDirectory) = "" ThenMsgBox ("请在上方选择正确的缓存文件夹!")Exit Sub
ElseIf MsgBox("确认删除吗？此操作不可恢复！", vbOKCancel, "确认") = vbOK ThenSet fs = CreateObject("scripting.filesystemobject")fs.deletefile Sheet1.TextBox5 & "\*.*"ElseExit SubEnd If
End If
End Sub

6、条件多选文件

Private Sub CommandButton1_Click()
Dim i
Dim arr()
Set FileDialogObject = Application.FileDialog(msoFileDialogFilePicker)With FileDialogObjectIf Sheet2.maintextbox1 <> "" And Dir(Sheet2.maintextbox1, vbDirectory) <> "" Then.InitialFileName = Sheet2.maintextbox1End If.AllowMultiSelect = True.Filters.Clear.Filters.Add "Excel/zip Files", "*.xls;*.xlsx;*.xlsb;*.zip;*.7z;*.rar"If .Show = -1 ThenSheet2.ListBox1.ClearFor i = 1 To .SelectedItems.CountSheet2.ListBox1.AddItem .SelectedItems(i)NextEnd IfEnd WithFor i = 0 To Sheet2.ListBox1.ListCount - 1Debug.Print Sheet2.ListBox1.List(i)Next
End Sub

VBA综合应用——解压并剔除Excel敏感数据相关推荐

暗幽***风恋组综合工具解压安装包2013元月27日更新版
此版在前版的基础上再次增加了S版工具,也再次修改了工具包里的工具,力求奉献出一个精简完美高效的工具包,但因精力实在有限,所以依然难免存在缺陷,请大家海涵- 前版的工具包集合了:UnPacKcN ...
python图片压缩pako_前端pako.js的解压, json 转excel文件下载
背景: 后台返回:gzip压缩后进行了base64编码的字符串. 解决办法 >引入pako.js ,xlsx >定义解压和压缩的方法 import XLSX from 'xlsx' co ...
最近很火的在线文件预览txt、doc、ppt、pdf、excel、jpg、png、zip、tar.gz等各种文件及压缩文件在线解压和预览，包括前后端设计和源码，编写搜索引擎多关键词检索名称和内容（四）
最近很火的在线文件预览txt.doc.ppt.pdf.excel.jpg.mp4.png.zip.tar.gz等各种文件及压缩文件在线解压和预览,包括前后端设计和源码,编写一个文件搜索引擎实现多关键词 ...
解压上传zip文件并获取excel表数据
1.maven <dependency><groupId>com.github.junrar</groupId><ar ...
Excel记录指定文件夹下的所有文件名；批量解压压缩包，处理压缩包套压缩包问题；
10.20 发现一个问题: 当压缩包过大,文件条目超过1048576时,rarfile库中的代码已经不能解决这个压缩包了,需要加装unrar库(from unrar import rarfile)和u ...
Excel 解压后结构
/** * author : WiKiChen * date: 2016-03-15 */ * 2007 后的excel 可以把后缀名改为zip,然后解压目录如下 * _rels *docProps ...
最近很火的在线文件预览txt、doc、ppt、pdf、excel、jpg、png、zip、tar.gz等各种文件及压缩文件在线解压和预览，包括前后端设计和源码，编写搜索引擎多关键词检索名称和内容（五）
最近很火的在线文件预览txt.doc.ppt.pdf.excel.jpg.mp4.png.zip.tar.gz等各种文件及压缩文件在线解压和预览,包括前后端设计和源码,编写一个文件搜索引擎实现多关键词 ...
python 图像压缩后前端解压_Python在后台自动解压各种压缩文件的实现方法
1.需求描述编写一个 Python 程序,每次下载压缩包形式的文件后,自动将内部文件解压到当前文件夹后将压缩包删除,通过本案例可以学到的知识点: os 模块综合应用 glob 模块综合应用利用 g ...
Python自动解压各种压缩文件
压缩文件是我们在使用电脑时经常会遇到的.压缩文件并不只有一种压缩模式.平常我们都是通过安装一些解压缩软件来打开这些不同的压缩文件.今天我们来谈一谈,如何用Python解压几种常见类型的压缩文件. ...

VBA综合应用——解压并剔除Excel敏感数据

VBA综合应用——解压并剔除Excel敏感数据相关推荐

最新文章

热门文章