未来博客

未来是简单的

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

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

作者:AntoniotheFuture

关键词:VBA,Excel自动化,办公自动化

开发平台:Excel2010

平台版本上限:2010

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

开发语言:VBA

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


主要功能:

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


目前优缺点:

优点:

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

缺点: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 = &H400

Sub 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 5
    If Sheet2.OLEObjects("optionbutton" & i).Object.Value = True And i = 1 Then
        format1 = xlOpenXMLWorkbook
        format2 = "xlsx"
    ElseIf Sheet2.OLEObjects("optionbutton" & i).Object.Value = True And i = 3 Then
        format1 = xlExcel12
        format2 = "xlsb"
    ElseIf Sheet2.OLEObjects("optionbutton" & i).Object.Value = True And i = 2 Then
        format1 = xlExcel8
        format2 = "xls"
    End If
Next

'判断表单有效性

If Sheet2.ListBox1.ListCount = 0 Then
    MsgBox ("请选择文件!")
    Exit Sub
ElseIf Sheet2.maintextbox2 = "" Or Dir(Sheet2.maintextbox2, vbDirectory) = "" Then
    MsgBox ("请选择正确的目标文件夹!")
    Exit Sub
ElseIf Sheet2.CheckBox1.Value = False And Sheet2.CheckBox2.Value = False And Sheet2.CheckBox3.Value = False And Sheet2.CheckBox4.Value = False Then
    If MsgBox("确认不剔除任何信息吗?", vbYesNo) = vbNo Then
        Exit Sub
    End If
ElseIf Sheet2.CheckBox7.Value = True And Sheet2.TextBox2 = "" Then
    MsgBox ("您已选择删除系统字符串,请在文本框内输入关键字!")
        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.ListCount
    road = listc.List(i - 1)
    Debug.Print road
    Const PINGSTART As Byte = 0
    Const PINGEND As Byte = 254
    Const PING_IP_IN_ONE_BAT As Long = 1
    '确定是否解压
    If road Like "*.xl*" Then
        Sheet2.ListBox3.AddItem road
    Else
        Application.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)
            Do
                GetExitCodeProcess pid, PExit
            Loop While PExit = STILL_ACTIVE

        '用winrar解压缩到缓存目录
        ElseIf Sheet1.OptionButton2.Value = True Then
            Shellstring2 = Sheet1.TextBox2 & " x " & Chr(34) & road & Chr(34) & " -y " & Chr(34) & Sheet1.TextBox5 & "/" & Chr(34)
            Debug.Print Shellstring2
            pid = Shell(Shellstring2, vbHide)
            pid = OpenProcess(PROCESS_QUERY_INFORMATION, False, pid)
            Do
                GetExitCodeProcess pid, PExit
            Loop While PExit = STILL_ACTIVE

        Else
            MsgBox ("未选择压缩程序!")
            Sheet1.Activate
            Exit Sub
        End If
    End If
Next

'遍历缓存文件夹
xlfile = Dir(Sheet1.TextBox5 & "\" & "*.xl*")
Do While xlfile <> ""
    Sheet2.ListBox3.AddItem Sheet1.TextBox5 & "\" & xlfile
    xlfile = Dir
Loop

'确定运行参数
For i = 1 To Sheet2.ListBox3.ListCount
    road = Sheet2.ListBox3.List(i - 1)
    Application.StatusBar = "正在扫描第" & i & "个文件:" & road
    newname = Split(road, "\")(UBound(Split(road, "\")))
    newname2 = Left(newname, InStr(newname, ".") - 1)
    If Sheet2.CheckBox7.Value = True And newname2 Like "*" & Sheet2.TextBox2 & "*" Then
        newname2 = Left(newname2, InStr(newname2, Sheet2.TextBox2) - 1)
    End If
    If Sheet2.CheckBox6.Value = True Then
        newname2 = 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 4
                    For words = 1 To Sheet1.OLEObjects("listbox" & li).Object.ListCount
                        '关键词判断
                        If InStr(sh.Cells(x, y), Sheet1.OLEObjects("listbox" & li).Object.List(words - 1)) Then
                            sh.Columns(y).Delete
                            y = y - 1
                            changes = changes + 1
                            GoTo exitloop1
                        End If
                    Next
                Next
            Next
            Application.StatusBar = "正在处理第" & i & "个文件:" & road
exitloop1:
        Next
    Next
    '生成新文件路径并保存
    Debug.Print Sheet2.maintextbox2 & "\" & newname
    Application.StatusBar = "正在保存第" & i & "个文件:" & road
    excel_App.DisplayAlerts = False
    excel_Book.SaveAs Sheet2.maintextbox2 & "\" & newname2, format1
    excel_Book.Close False
    excel_App.DisplayAlerts = True
    Set excel_Book = Nothing
    Sheet2.ListBox2.AddItem Sheet2.maintextbox2 & "\" & newname2 & "." & format2
    Sheet2.TextBox1 = Sheet2.TextBox1 & Chr(10) & road & "执行成功!"
    Application.StatusBar = "准备就绪"
    
'判断是否打开新文件
If Sheet2.CheckBox5 = True Then
    Application.StatusBar = False
    Workbooks.Open Sheet2.maintextbox2 & "\" & newname2 & "." & format2, 0, True
End If
nextchange:
Next

MsgBox ("执行成功,剔除" & changes & "列数据")

excel_App.Quit
Set excel_App = Nothing

Exit Sub

'错误事件
changeerror:
Sheet2.TextBox1 = Sheet2.TextBox1 & Chr(10) & road & "执行失败!"
GoTo nextchange
End Sub

2、计算缓存:

Sub cfoldersize()
'计算缓存占用量
Set fso = CreateObject("scripting.filesystemobject")
If Sheet1.TextBox5 = "" Then
    MsgBox ("请在上方选择缓存文件夹!")
    Exit Sub
Else
    If Dir(Sheet1.TextBox5, vbDirectory) = "" Then
        MsgBox ("缓存目录不存在,请重新设置缓存目录!")
        Sheet1.Activate
        Exit Sub
    Else
        Set 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
cfoldersize

Sheet2.TextBox1.Text = ""

'遍历工作表并赋值到控件
For y = 1 To 4
    Sheet1.OLEObjects("listbox" & y).Object.Clear
    For x = 2 To 100
        If Sheet3.Cells(x, y) <> "" Then
            Sheet1.OLEObjects("listbox" & y).Object.AddItem Sheet3.Cells(x, y)
        Else
            Exit For
        End If
    Next
Next

'遍历控件并赋值到工作表
For y = 1 To 4
    For x = 1 To Sheet1.OLEObjects("listbox" & y).Object.ListCount
        Sheet3.Cells(x + 1, y) = Sheet1.OLEObjects("listbox" & y).Object.List(x - 1)
        Debug.Print x & " " & y
    Next
Next

'遍历默认设置并赋值到主界面
For y = 1 To 5
    If Sheet1.OLEObjects("optionbutton" & y + 2).Object.Value = True Then
        Sheet2.OLEObjects("optionbutton" & y).Object.Value = True
    End If
Next

End Sub

4、检验设置

Sub settingable()
'检验设置参数可用性
    If Sheet1.OptionButton1.Value = True Then
        If Sheet1.TextBox1 <> "" And Dir(Sheet1.TextBox1, vbDirectory) <> "" Then
            Exit Sub
        Else
            GoTo Error1
        End If
    ElseIf Sheet1.OptionButton2.Value = True Then
        If Sheet1.TextBox2 <> "" And Dir(Sheet1.TextBox2, vbDirectory) <> "" Then
            Exit Sub
        Else
            GoTo Error1
        End If
    Else
        Exit Sub
    End If
Error1:
        MsgBox ("请选择压缩程序及压缩程序路径")
    
End Sub

5、清空缓存

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

6、条件多选文件

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

阅读更多
个人分类: VBA.综合应用
下一篇网页爬虫实践——VBA调用JS事件
想对作者说点什么? 我来说一句

EXCel VBA 经典应用例子

2018年03月14日 304KB 下载

没有更多推荐了,返回首页

关闭
关闭