分类
VBA

VBA应用——合并文件

日常工作中,我们有时候会需要将多份相同格式的工作簿合并到一个工作表中,进行数据分析和处理.

这时候,如果你一个个的打开粘贴,是非常耗时和耗费精力的.而且手工操作,免不了偶尔出个错,到了最后发现数据不对,一条条核对时候,就会在想,有没有什么操作,可以让你的双手解放一些呢?答案就是VBA.

下面一份代码,就是阁主写来合并多个工作簿的.现在放出来,以飨读者.

疏漏之处,还请包涵~

有问题欢迎指出,至于改不改嘛~看我心情.

Sub 合并文件()
    '注意,合并多个工作簿到当前激活工作簿的激活工作表,而不是代码所在工作簿
    '副作用:本代码有两项副作用,1是会取消所有的合并单元格,2是会取消所有的筛选,使用前,请确认是否可以接受.(可以放心的是,数据源工作簿并不会发生改变)
    Dim actWb As Workbook, actSh As Worksheet
    Set actWb = ActiveWorkbook
    Set actSh = ActiveSheet
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show = True Then
            Dim arrs
            Set arrs = .SelectedItems
        End If
        
    End With
    Dim s
    For Each s In arrs
        Dim obj
        Set obj = GetObject(s)
        Dim Sh As Worksheet
        For Each Sh In obj.Sheets
            '这里会遍历工作簿的所有的工作表,如果只需要遍历指定的工作表,请添加if条件
            'if sh.name="Sheet1" then
            Sh.Cells.UnMerge
            On Error Resume Next
            Sh.Cells.AutoFilter
            Sh.UsedRange.Copy actSh.Range("a1").Offset(actSh.UsedRange.Rows.Count + actSh.UsedRange.Row - 1, 0)
            If Err.Number <> 0 Then
                Debug.Print Err.Description & vbCrLf & Sh.Parent.Name & vbTab & Sh.Name
            End If
            On Error GoTo 0
            'end if
        Next
        obj.Close (False)
        Set obj = Nothing
        Set Sh = Nothing
    Next
End Sub

 

分类
VBA

VBA应用——遍历文件夹及其子文件夹

经常使用excel来进行数据统计和汇总分析的我们有时候需要将很多年份的数据进行汇总,如果我们使用VBA来帮助我们汇总,将会节约我们很多的时间。

如果需要汇总的文件都在一个文件夹中而不存在子文件夹,我们可以在网上找到很多简单的代码,告诉我们用VBA提供的Dir函数来获取文件列表。但如果我们需要汇总的文件有一些在子文件夹中,我们使用Dir来获取文件列表的方法就不太好用了。

怎么办呢?

下面,阁主呈上一份能够遍历文件夹及子文件夹获取文件列表的代码,以飨读者。

Function getFileList(Optional ByVal dirStr As String) As Collection
    Dim tmpStr As String, fileCollection As Collection '定义一个集合,来存放Dir出来的文件或文件夹名称
    '如果路径不带“\”,则加上
    If Right(dirStr, 1) <> "\" Then
        dirStr = dirStr & "\"
    End If
    '第一次Dir,遍历目录,并将文件或文件夹名称存入集合
    on error Resume next
    tmpStr = Dir(dirStr, vbDirectory)
    If Err.Number <> 0 Then
        Set getFileList = Nothing
        Exit Function
    End If
    on error goto 0
    Set fileCollection = New Collection
    While (tmpStr <> "")
        If tmpStr <> "." And tmpStr <> ".." Then
            fileCollection.Add (dirStr & tmpStr)
        End If
        tmpStr = Dir
    Wend
    '针对上述遍历出的文件或文件夹名称,递归遍历子目录
    Dim i
    i = 1
    While i <= fileCollection.Count
    '遍历刚才获取到的目录内文件夹和文件列表,递归调用本函数实现对子目录的遍历。
        On Error Resume Next
        Dim tmparr
        If fileCollection.Item(i) <> dirStr & "" And fileCollection.Item(i) <> dirStr & "." And fileCollection.Item(i) <> dirStr & ".." Then
            Set tmparr = getFileList(fileCollection.Item(i)) '递归调用,下一层目录
            If Err.Number = 0 Then
                
                Dim k, l
                l = i
                For k = 1 To tmparr.Count
                    fileCollection.Add tmparr(k), after:=l
                    l = l + 1
                Next k
                i = l
            Else
                Err.Clear
            End If
        End If
        On Error GoTo 0
        i = i + 1
    Wend
    Set getFileList = fileCollection
End Function

食用方法:

函数返回了一个Collection对象,可以通过遍历Collection对象的值来获得目录和文件列表。

Sub test()
    Dim s
    Set s = getFileList("d:\xx文件夹")
    Dim k
    For Each k In s
        Debug.Print k
    Next k
End Sub

 

分类
VBA

分享一些VBA例程

卷 VBA精粹(修订版) 的文件夹 PATH 列表
卷序列号为 7839-3C48
I:.
├─VBA精粹修订版—示例文件
│  ├─第1篇 Excel VBA基础
│  │  └─第1章 VBA基础
│  │          技巧1 录制宏并获取有效的代码_1.xls
│  │          技巧1 录制宏并获取有效的代码_2.xls
│  │          技巧2 执行宏(调用过程)的5种方式_1.xls
│  │          技巧2 执行宏(调用过程)的5种方式_2.xls
│  │          技巧2 执行宏(调用过程)的5种方式_3.xls
│  │          技巧2 执行宏(调用过程)的5种方式_4.xls
│  │          技巧2 执行宏(调用过程)的5种方式_5.xls
│  │          
│  ├─第2篇 操作Excel对象
│  │  ├─第2章 窗口和应用程序
│  │  │      技巧10 隐藏Excel主窗口_1.xls
│  │  │      技巧10 隐藏Excel主窗口_2.xls
│  │  │      技巧11 隐藏工作簿窗口.xls
│  │  │      技巧12 禁止触发相关Excel事件.xls
│  │  │      技巧13 个性化Excel状态栏信息.xls
│  │  │      技巧14 Excel中的“定时器”.xls
│  │  │      技巧15 实现倒计时功能.xls
│  │  │      技巧16 制作精美的数字秒表.xls
│  │  │      技巧17 宏代码运行中的“暂停”.xls
│  │  │      技巧18 防止用户干预宏代码的运行.xls
│  │  │      技巧19 调用变量名称指定的宏过程.xls
│  │  │      技巧20 捕捉特定键或特定的组合键输入.xls
│  │  │      技巧21 模拟手工选定单元格中的部分内容.xls
│  │  │      技巧22 巧妙捕获用户中断.xls
│  │  │      技巧23 更换Excel标题栏图标.zip
│  │  │      技巧24 控制新建工作簿的工作表名称.xls
│  │  │      技巧6 个性化Excel标题栏.xls
│  │  │      技巧7 最大化应用程序窗口.xls
│  │  │      技巧8 真正的全屏显示.xls
│  │  │      技巧9 限定工作簿窗口大小.xls
│  │  │      
│  │  ├─第3章 工作表和工作簿
│  │  │      技巧26 在工作簿中轻松添加新工作表.xls
│  │  │      技巧27 防止更改工作表的名称.xls
│  │  │      技巧28 删除工作表时不显示警告信息.xls
│  │  │      技巧29 批量删除未选中的工作表.xls
│  │  │      技巧30 判断工作表是否为空工作表.xls
│  │  │      技巧31 判断工作簿中是否存在指定名称的工作表.xls
│  │  │      技巧32 按名称排序工作表.xls
│  │  │      技巧33 限制工作表滚动区域.xls
│  │  │      技巧34 操作受保护的工作表.xls
│  │  │      技巧35 不显示双击被保护单元格时出现的提示信息框.xls
│  │  │      技巧36 在指定单元格区域中禁止显示右键菜单.xls
│  │  │      技巧37 只对工作表中的指定区域执行重新计算.xls
│  │  │      技巧38 快速全选工作簿中的所有工作表.xls
│  │  │      技巧39 显示唯一工作表.xls
│  │  │      技巧40 轻松判断是否存在指定名称的工作簿.xls
│  │  │      技巧41 新建仅包含一张工作表的工作簿.xls
│  │  │      技巧42 打开工作簿时不显示更新链接对话框.zip
│  │  │      技巧43 打开指定路径下的所有工作簿文件.xls
│  │  │      技巧44 按特殊要求打开文本文件.zip
│  │  │      技巧45 打开包含VBA代码的工作簿时禁用宏.zip
│  │  │      技巧46 使用宏代码保存工作簿的3种方法.xls
│  │  │      技巧47 保存指定工作表到新的工作簿文件.xls
│  │  │      技巧48 禁止工作簿文件另存.xls
│  │  │      技巧49 关闭工作簿不显示保存对话框.xls
│  │  │      技巧50 控制工作簿只能通过代码关闭.xls
│  │  │      技巧52 定义隐藏的名称.xls
│  │  │      技巧53 带“自杀”功能的工作簿.xls
│  │  │      技巧54 限制工作簿的使用次数.xls
│  │  │      技巧55 禁用宏则关闭工作簿.xls
│  │  │      技巧56 奇偶页打印.xls
│  │  │      技巧57 打印预览时不触发BeforePrint事件.xls
│  │  │      
│  │  ├─第4章 使用Range对象
│  │  │      技巧100 判断是否选中整行.xls
│  │  │      技巧101 工作表中一次插入多行.xls
│  │  │      技巧102 控制插入单元格区域的格式.xls
│  │  │      技巧103 批量删除偶数行.xls
│  │  │      技巧104 剔除空单元格后重排数据.xls
│  │  │      技巧105 超过3个关键字的数据排序.xls
│  │  │      技巧106 按单元格颜色排序.xls
│  │  │      技巧107 利用自定义序列进行排序.xls
│  │  │      技巧108 包含合并单元格的数据列表排序.xls
│  │  │      技巧58 在宏代码中引用单元格区域的5种方法.xls
│  │  │      技巧59 获得指定行(或列)中最后一个非空单元格.xls
│  │  │      技巧61 随心所欲复制单元格区域.xls
│  │  │      技巧62 仅复制数值到另一区域.xls
│  │  │      技巧63 获取两个单元格区域的交叉区域.xls
│  │  │      技巧64 联合多个单元格区域.xls
│  │  │      技巧65 判断一个区域是否包含在另一个区域中.xls
│  │  │      技巧66 设置字符格式.xls
│  │  │      技巧67 以毫米为单位设置单元格行高列宽.xls
│  │  │      技巧68 所见即所得-将数字格式的显示结果作为单元格数值.xls
│  │  │      技巧69 为单元格区域添加边框的快捷方法.xls
│  │  │      技巧70 高亮显示单元格区域.xls
│  │  │      技巧71 动态设置单元格数据有效性序列.xls
│  │  │      技巧72 使用宏代码在单元格中创建公式.xls
│  │  │      技巧73 快速将单元格中的公式转换为数值.xls
│  │  │      技巧74 准确判断单元格公式是否存在错误.xls
│  │  │      技巧75 返回指定列的列标.xls
│  │  │      技巧76 在VBA中使用数组公式.xls
│  │  │      技巧77 判断单元格是否存在批注.xls
│  │  │      技巧78 为单元格添加批注.xls
│  │  │      技巧79 获取、修改和补充批注中的内容.xls
│  │  │      技巧80 个性化批注外观.xls
│  │  │      技巧81 显示图片批注.zip
│  │  │      技巧82 设置批注字体.xls
│  │  │      技巧83 快速判断单元格区域是否存在部分合并单元格.xls
│  │  │      技巧84 合并单元格时连接每个单元格的文本.xls
│  │  │      技巧85 取消合并单元格时在每个单元格中保留内容.xls
│  │  │      技巧86 合并内容相同的连续单元格.xls
│  │  │      技巧87 快速获得区域中最早和最后出现的数值位置.xls
│  │  │      技巧88 高效的按单元格颜色计数自定义函数.xls
│  │  │      技巧90 汇总不同工作表的数据区域.xls
│  │  │      技巧91 汇总多个工作簿的工作表.zip
│  │  │      技巧92 按指定条件自动筛选数据.xls
│  │  │      技巧93 多条件筛选.xls
│  │  │      技巧94 获得符合自动筛选条件的记录条数.xls
│  │  │      技巧95 判断筛选结果是否为空.xls
│  │  │      技巧96 复制自动筛选后的数据区域.xls
│  │  │      技巧97 获得自动筛选条件.xls
│  │  │      技巧98 使用高级筛选获得不重复记录.xls
│  │  │      技巧99 删除空行.xls
│  │  │      
│  │  └─第5章 使用Shape对象
│  │      │  技巧109 在工作表中指定位置添加图形对象.xls
│  │      │  技巧110 为一个图形对象指定不同宏代码.xls
│  │      │  技巧111 快速将多个图形对象进行组合.xls
│  │      │  技巧112 遍历工作表的图形对象.xls
│  │      │  技巧113 将工作表中图形对象另存为图片.xls
│  │      │  技巧115 通过链接显示VBE代码窗口.xls
│  │      │  
│  │      └─技巧114 在员工登记表中自动插入图片
│  │              001.png
│  │              002.png
│  │              003.png
│  │              004.png
│  │              技巧114 在员工登记表中自动插入图片.xls
│  │              
│  ├─第3篇 函数与加载宏的应用
│  │  ├─第6章 函数的应用
│  │  │      技巧116 输入漂亮的图形字符.xls
│  │  │      技巧117 获取字符串出现次数的简单方法.xls
│  │  │      技巧118 计算两个日期的间隔.xls
│  │  │      技巧119 获取指定日期所属月份的最后一天.xls
│  │  │      技巧120 在注册表中记录工作簿的使用情况.xls
│  │  │      技巧121 获取指定数据在数组中的位置.xls
│  │  │      技巧122 获取指定数据在数组中出现的次数.xls
│  │  │      技巧123 获取数组的维数.xls
│  │  │      技巧124 改变动态二维数组的行边界.xls
│  │  │      技巧125 跳过四舍五入的陷阱.xls
│  │  │      技巧126 自动填入匹配的内容.xls
│  │  │      技巧127 汉字和区位码的转换.xls
│  │  │      技巧128 定制自定义函数的信息.xls
│  │  │      
│  │  └─第7章 加载宏应用
│  │          技巧129 隐藏工作簿中的所有工作表.xls
│  │          技巧130 Excel加载宏的加载.zip
│  │          技巧131 动态载入加载宏.zip
│  │          技巧132 定制加载宏信息.zip
│  │          技巧133 定制加载宏菜单和工具栏.zip
│  │          技巧134 定制打开Excel文档时的启动画面.zip
│  │          技巧135 加载宏中工作表的妙用.zip
│  │          
│  ├─第4篇 交互式设计
│  │  ├─第10章 内置对话框
│  │  │      技巧146 活用Excel的内置对话框.xls
│  │  │      技巧147 获取用户选定文件的文件名.xls
│  │  │      技巧148 使用“另存为”对话框备份文件.xls
│  │  │      
│  │  ├─第11章 菜单和工具栏
│  │  │      技巧149 自定义Excel菜单栏_1.xls
│  │  │      技巧149 自定义Excel菜单栏_2.xls
│  │  │      技巧149 自定义Excel菜单栏_3.xls
│  │  │      技巧149 自定义Excel菜单栏_4.xls
│  │  │      技巧149 自定义Excel菜单栏_5.xls
│  │  │      技巧150 创建图表自定义菜单.xls
│  │  │      技巧151 定制右键快捷菜单_1.xls
│  │  │      技巧151 定制右键快捷菜单_2.xls
│  │  │      技巧152 创建自定义工具栏.xls
│  │  │      技巧153 为工具栏按钮添加自定义图标.zip
│  │  │      技巧154 自定义工作簿标题和图标.zip
│  │  │      技巧155 屏蔽工具栏上的“键入需要帮助的问题”下拉框.xls
│  │  │      技巧156 禁用工具栏的自定义功能.xls
│  │  │      
│  │  ├─第12章 控件的应用
│  │  │  │  技巧158 遍历控件的多种方法_1.xls
│  │  │  │  技巧158 遍历控件的多种方法_2.xls
│  │  │  │  技巧158 遍历控件的多种方法_3.xls
│  │  │  │  技巧158 遍历控件的多种方法_4.xls
│  │  │  │  技巧159  限制文本框的输入.xls
│  │  │  │  技巧160 为文本框添加右键快捷菜单.xls
│  │  │  │  技巧161 文本框自动输入.xls
│  │  │  │  技巧162 自动选择文本框内容.xls
│  │  │  │  技巧163 设置文本框的数据格式.xls
│  │  │  │  技巧164 将光标返回文本框中.xls
│  │  │  │  技巧165 在组合框和列表框中添加列表项_1.xls
│  │  │  │  技巧165 在组合框和列表框中添加列表项_2.xls
│  │  │  │  技巧165 在组合框和列表框中添加列表项_3.xls
│  │  │  │  技巧166 设置多列组合框和列表框_1.xls
│  │  │  │  技巧166 设置多列组合框和列表框_2.xls
│  │  │  │  技巧167 输入时逐步提示信息.xls
│  │  │  │  技巧168 去除列表框数据源的重复值和空格.xls
│  │  │  │  技巧169 使用代码在工作表上添加控件.xls
│  │  │  │  技巧170 使控件跟随活动单元格.xls
│  │  │  │  技巧171 使用Listview控件显示数据.xls
│  │  │  │  技巧172 使用TreeView控件显示层次.xls
│  │  │  │  技巧173 使用spreadsheet控件显示数据.xls
│  │  │  │  技巧176 解决微调框最小变动量小于1的问题.xls
│  │  │  │  技巧177 使标签控件文字垂直居中对齐.xls
│  │  │  │  技巧178 制作进度条_1.xls
│  │  │  │  技巧178 制作进度条_2.xls
│  │  │  │  技巧179 不打印工作表中的控件.xls
│  │  │  │  技巧180 自动注册新控件.zip
│  │  │  │  
│  │  │  ├─技巧174 使用AniGif控件显示GIF动画图片
│  │  │  │      VBAniGIF.ocx
│  │  │  │      gif001.gif
│  │  │  │      技巧174 使用AniGif控件显示GIF动画图片.xls
│  │  │  │      
│  │  │  └─技巧175 使用ShockwaveFlash控件播放Flash文件
│  │  │          Flash9d.ocx
│  │  │          face.swf
│  │  │          技巧175 使用ShockwaveFlash控件播放Flash文件.xls
│  │  │          
│  │  ├─第13章 用户窗体的应用
│  │  │      技巧181 调用非模式用户窗体.xls
│  │  │      技巧182 在用户窗体标题栏上添加图标.xls
│  │  │      技巧183 制作欢迎界面窗体.xls
│  │  │      技巧184 在用户窗体标题栏上添加最大化和最小化按钮.xls
│  │  │      技巧185 禁用用户窗体标题栏的关闭按钮.xls
│  │  │      技巧186 在用户窗体框架中使用滚动条.xls
│  │  │      技巧187 制作年月选择窗体.xls
│  │  │      技巧188 调整用户窗体的显示位置.xls
│  │  │      技巧189 在用户窗体上显示图表.xls
│  │  │      技巧190 在用户窗体运行时拖动控件.xls
│  │  │      技巧191 使用自定义颜色设置用户窗体颜色.xls
│  │  │      
│  │  ├─第8章 使用消息框
│  │  │      技巧136 显示简单的信息提示.xls
│  │  │      技巧137 定制个性化的消息框.xls
│  │  │      技巧138 获得消息框的返回值.xls
│  │  │      技巧139 在消息框中排版.xls
│  │  │      技巧140 对齐消息框中显示的信息.xls
│  │  │      技巧141 自动关闭的消息框.xls
│  │  │      
│  │  └─第9章 简单的数据录入
│  │          技巧142 为用户提供简单的输入框.xls
│  │          技巧143 防止用户在输入框中输入错误信息.xls
│  │          技巧144 使用对话框获取区域地址.xls
│  │          技巧145 打造更安全的密码输入界面.xls
│  │          
│  ├─第5篇 文件系统操作
│  │  ├─第14章 目录和文件操作
│  │  │      技巧192 设定“打开”对话框的默认路径和文件名.xls
│  │  │      技巧193 判断文件或文件夹是否存在.xls
│  │  │      技巧194 顺序搜索文件.xls
│  │  │      技巧195 获取常用的系统路径.xls
│  │  │      技巧196 灵活处理指定的文件.xls
│  │  │      技巧197 操作文件夹.xls
│  │  │      
│  │  └─第15章 文件的输入输出
│  │      │  技巧198 读取未打开的Excel文件内容.xls
│  │      │  技巧199 判断文件是否处于锁定状态.xls
│  │      │  技巧200 读写文本文件.xls
│  │      │  技巧201 读写二进制文件.xls
│  │      │  技巧202 使用FileSystemObject对象.xls
│  │      │  
│  │      └─test
│  │          │  ansitry.txt
│  │          │  test.txt
│  │          │  test.xls
│  │          │  test1.txt
│  │          │  test4.txt
│  │          │  thewasteland1.txt
│  │          │  
│  │          └─test
│  │                  test.txt
│  │                  
│  ├─第6篇 数据库应用
│  │  └─第16章 ADO应用
│  │      │  TestFile.xls
│  │      │  学校管理.mdb
│  │      │  技巧204 动态创建Access 数据库文件.xls
│  │      │  技巧205 获取数据库所有表的名称.xls
│  │      │  技巧206 动态建立数据表.xls
│  │      │  技巧207 添加主键.xls
│  │      │  技巧208 向表中添加字段.xls
│  │      │  技巧209 向表中增加并更新记录.xls
│  │      │  技巧210 批量删除数据库中的记录.xls
│  │      │  技巧211 批量修改数据库中的记录.xls
│  │      │  技巧212 在数据库中存储相片.xls
│  │      │  技巧213 制作带相片的学生证.xls
│  │      │  技巧214 从多重表中提取信息.xls
│  │      │  技巧215 Excel与Access数据库互动.xls
│  │      │  技巧216 在数据库中创建视图.xls
│  │      │  技巧217 动态创建链接表.xls
│  │      │  技巧218 使用无表记录集分析数据.xls
│  │      │  技巧219 记录集的实体化操作.xls
│  │      │  技巧220 查询文本文件中的数据.zip
│  │      │  技巧221 轻松导入VFP数据表.zip
│  │      │  技巧222 有用的交叉表查询.xls
│  │      │  技巧223 不打开工作簿获取工作表的名称.xls
│  │      │  技巧224 在数组中存储查询结果.xls
│  │      │  技巧225 使用内、外连接实现字段配对.xls
│  │      │  技巧226 复杂的多类型表内连接关联查询.xls
│  │      │  技巧227 生成各种统计报表.xls
│  │      │  
│  │      ├─pic
│  │      │      100001.gif
│  │      │      100002.gif
│  │      │      100003.gif
│  │      │      100004.gif
│  │      │      100005.gif
│  │      │      100006.gif
│  │      │      100007.gif
│  │      │      100008.gif
│  │      │      100009.gif
│  │      │      100010.gif
│  │      │      100011.gif
│  │      │      100012.gif
│  │      │      100015.gif
│  │      │      100016.gif
│  │      │      100019.gif
│  │      │      100020.gif
│  │      │      100021.gif
│  │      │      100022.gif
│  │      │      100023.gif
│  │      │      100024.gif
│  │      │      100025.gif
│  │      │      100026.gif
│  │      │      100027.gif
│  │      │      100028.gif
│  │      │      100029.gif
│  │      │      100030.gif
│  │      │      100031.gif
│  │      │      100032.gif
│  │      │      100033.gif
│  │      │      100034.gif
│  │      │      100035.gif
│  │      │      100036.gif
│  │      │      100037.gif
│  │      │      100038.gif
│  │      │      100039.gif
│  │      │      100040.gif
│  │      │      100041.gif
│  │      │      100042.gif
│  │      │      100043.gif
│  │      │      100044.gif
│  │      │      100045.gif
│  │      │      100046.gif
│  │      │      100047.gif
│  │      │      100048.gif
│  │      │      100049.gif
│  │      │      100050.gif
│  │      │      100051.gif
│  │      │      100052.gif
│  │      │      100053.gif
│  │      │      100054.gif
│  │      │      100055.gif
│  │      │      100056.gif
│  │      │      100057.gif
│  │      │      100058.gif
│  │      │      100059.gif
│  │      │      100060.gif
│  │      │      100061.gif
│  │      │      100062.gif
│  │      │      100065.gif
│  │      │      100066.gif
│  │      │      100067.gif
│  │      │      100068.gif
│  │      │      100069.gif
│  │      │      100070.gif
│  │      │      100071.gif
│  │      │      100072.gif
│  │      │      100073.gif
│  │      │      100074.gif
│  │      │      100075.gif
│  │      │      100076.gif
│  │      │      100077.gif
│  │      │      100078.gif
│  │      │      100079.gif
│  │      │      100080.gif
│  │      │      100081.gif
│  │      │      100082.gif
│  │      │      100083.gif
│  │      │      100084.gif
│  │      │      100085.gif
│  │      │      100086.gif
│  │      │      100087.gif
│  │      │      100088.gif
│  │      │      100089.gif
│  │      │      100091.gif
│  │      │      100092.gif
│  │      │      100093.gif
│  │      │      100094.gif
│  │      │      100095.gif
│  │      │      100096.gif
│  │      │      100097.gif
│  │      │      100098.gif
│  │      │      100099.gif
│  │      │      100100.gif
│  │      │      100101.gif
│  │      │      100102.gif
│  │      │      100103.gif
│  │      │      100104.gif
│  │      │      100105.gif
│  │      │      100106.gif
│  │      │      100107.gif
│  │      │      100108.gif
│  │      │      100109.gif
│  │      │      100110.gif
│  │      │      
│  │      ├─考试成绩
│  │      │      考试成绩表.xls
│  │      │      
│  │      └─链接表
│  │              奖学金.dbf
│  │              奖学金.xls
│  │              奖金.mdb
│  │              捐款.txt
│  │              
│  ├─第7篇 高级编程
│  │  ├─第17章 Excel与Internet
│  │  │      技巧228 创建和打开超链接.xls
│  │  │      技巧229 映射网络驱动器.xls
│  │  │      技巧230 获取外网和本地IP地址.xls
│  │  │      技巧231 使用Lotus Notes发送Email.xls
│  │  │      技巧232 了解HTML及DOM对象.zip
│  │  │      技巧233 制作简易的网页浏览器.xls
│  │  │      技巧234 自动登录到网页.xls
│  │  │      技巧235 网页查询及下载.xls
│  │  │      技巧236 使用QueryTable下载网页数据.xls
│  │  │      
│  │  ├─第18章 Excel操作XML
│  │  │      技巧237 快速创建XML文件.xls
│  │  │      技巧238 转换MDB文件为XML文件.zip
│  │  │      技巧239 定制自己的Excel RSS阅读器.xls
│  │  │      
│  │  ├─第19章 操作其他Office应用程序
│  │  │      技巧240 透视前期绑定与后期绑定技术.txt
│  │  │      技巧241 将电子表格数据通过Outlook邮件发送.txt
│  │  │      技巧242 将电子表格数据输出到Word新文档.xls
│  │  │      技巧243 将电子表格数据输出到PowerPoint演示稿.xls
│  │  │      
│  │  ├─第20章 使用类模块
│  │  │      技巧244 子类化实现控件数组.xls
│  │  │      技巧245 捕获包含公式的单元格的值改变.xls
│  │  │      技巧246 设置类的缺省成员.xls
│  │  │      技巧247 实现可列举的类成员.xls
│  │  │      技巧248 实现用户窗体菜单.xls
│  │  │      技巧249 构建多态类.xls
│  │  │      
│  │  └─第21章 VBE相关操作
│  │          技巧250 判断指定工作簿中是否包含宏代码.zip
│  │          技巧251 快速删除指定工作簿中的宏代码.zip
│  │          技巧252 快速列出模块中的所有过程.xls
│  │          技巧253 自动添加模块和过程.zip
│  │          技巧254 建立事件过程的简易方法.xls
│  │          技巧255 过程更新策略.zip
│  │          技巧256 自动添加用户窗体及控件.xls
│  │          技巧257 巧妙的VBE陷阱.xls
│  │          技巧258 检索和设置工程引用.xls
│  │          技巧259 自动设置信任对VBE的访问.xls
│  │          技巧260 轻松打开受密码保护的.xls
│  │          技巧261 利用保护项目的两把锁.zip
│  │          
│  └─第8篇 代码调试及优化
│      ├─第22章 代码调试
│      │      技巧263 使用Debug对象.xls
│      │      技巧264 使用立即窗口.xls
│      │      技巧265 使用本地窗口.xls
│      │      技巧266 使用监视窗口.xls
│      │      
│      ├─第23章 错误处理
│      │      技巧267 捕捉错误.xls
│      │      技巧268 处理错误.xls
│      │      技巧269 退出错误处理过程.xls
│      │      技巧270 生成错误.xls
│      │      技巧271 错误处理的层次.xls
│      │      
│      └─第24章 代码优化
│              技巧273 使用工作表函数或方法.xls
│              技巧275 避免使用Variant类型.xls
│              技巧276 减少dot的数量.xls
│              技巧278 让代码专注执行.xls
│              
├─【赠】《Excel 图表实战技巧精粹》部分实例视频
│      C01_玩转图表数据系列.wmv
│      C02_高级饼图制作.wmv
│      C03_大事记图与云梯图.wmv
│      
├─【赠】《Excel 数据处理与分析实战技巧精粹》部分实例视频
│      A02_电子表格数据安全维护.wmv
│      A11_规划求解计算旅行商问题.wmv
│      
├─【赠】《Excel函数与公式实战技巧精粹》部分实例视频
│      B01_Excel公式通用技巧.wmv
│      B02_Excel函数查询技术之一.wmv
│      B03_Excel函数查询技术之二.wmv
│      B04_Excel函数的趣味应用之一.wmv
│      B05_Excel函数的趣味应用之二.wmv
│      B06_Excel宏表函数的应用.wmv
│      B07_活用Excel文本函数.wmv
│      B08_活用Excel日期函数.wmv
│      B09_活用Excel透视表函数之一.wmv
│      B10_活用Excel透视表函数之二.wmv
│      B11_运用函数DIY公文管理系统.wmv
│      
├─【赠】免费软件-Excel易用宝
│      EZTESetup.exe
│      关于Excel易用宝.txt
│      
└─本书部分实例视频
        D01_ExcelVBA代码调试技巧.wmv
        D02_使用VBA灵活控制Shape.wmv
        D03_制作带自杀功能的工作簿.wmv
        D04_制作并应用Excel加载宏.wmv
        D05_在ExcelVBA中的ADO应用技巧之一.wmv
        D06_在ExcelVBA中的ADO应用技巧之二.wmv
        D07_在VBA中使用类创建控件数组.wmv
        D08_输入时逐步提示信息的实现.wmv
        

 

分类
excel知识日志

Excel应用——生成二维码

现在,二维码应用的越来越普遍了。很多时候,我们都需要生成二维码。而在Office家族中,我们可以通过VBA里的barcodectrl控件来生成条码和二维码。但是遇到中文字符的情况下,barcodectrl控件生成的效果就不理想了。

经过搜索,发现是因为excel中使用的编码解码后不支持中文,所以,阁主转向了zxing的怀抱。zxing是一个基于java语言的开源二维码/条码生成和识别库。已经有大牛将其封装为.net可用的形式zxing.net 版。阁主基于zxing.net库编写了一个excel生成二维码的加载项。

Imports Microsoft.Office.Tools.Ribbon
Imports ZXing.BarcodeFormat
Imports ZXing.QrCode.Internal.QRCode
Imports System.Drawing
Imports System.ComponentModel
Imports ZXing.QrCode.Internal
Public Class Ribbon1
    Private Sub Ribbon1_Load(ByVal sender As System.Object, ByVal e As RibbonUIEventArgs) Handles MyBase.Load
        DropDown1.SelectedItemIndex = My.Settings.Level
        EditBox1.Text = My.Settings.size
        For i As Integer = 0 To 40
            Dim rf As RibbonFactory = Me.Factory
            Dim tmpitem As RibbonDropDownItem = rf.CreateRibbonDropDownItem
            tmpitem.Label = CStr(i)
            ComboBox1.Items.Add(tmpitem)
        Next
        ComboBox1.Text = My.Settings.version
        CheckBox1.Checked = My.Settings.changeSize
        If CheckBox1.Checked Then
            EditBox1.Enabled = True
        Else
            EditBox1.Enabled = False
        End If
    End Sub
    Private Sub Button1_Click(sender As Object, e As RibbonControlEventArgs) Handles Button1.Click
        Dim app As Global.Microsoft.Office.Interop.Excel.Application
        Dim hitset As IDictionary(Of ZXing.EncodeHintType, Object) = New Dictionary(Of ZXing.EncodeHintType, Object)
        hitset.Add(ZXing.EncodeHintType.CHARACTER_SET, "utf-8")
        hitset.Add(ZXing.EncodeHintType.DISABLE_ECI, getDisableEci)
        hitset.Add(ZXing.EncodeHintType.ERROR_CORRECTION, getErrorCurrentLevel)
        hitset.Add(key:=ZXing.EncodeHintType.MARGIN, value:=0)
        If ComboBox1.Text <> "0" Then hitset.Add(key:=ZXing.EncodeHintType.QR_VERSION, value:=CInt(ComboBox1.Text))
        app = Globals.ThisAddIn.Application
        Dim img As New ZXing.QrCode.QRCodeWriter

        Dim bitmat As ZXing.Common.BitMatrix
        Dim bw As New ZXing.BarcodeWriter
        Dim bitmap1 As Bitmap
        Dim str As String
        Try
            Dim frm As New Form1
            frm.ShowDialog()
            str = frm.TextBox1.Text
            If String.IsNullOrEmpty(str) Then
                app = Nothing
                img = Nothing
                bw = Nothing
                frm.Dispose()
                Exit Sub
            End If
        Catch ex As Exception
            app = Nothing
            img = Nothing
            bw = Nothing
            Exit Sub
        End Try

        Dim s2 As Integer()
        Try
            bitmat = img.encode(str, format:=ZXing.BarcodeFormat.QR_CODE, width:=My.Settings.size, height:=My.Settings.size, hints:=hitset)
            Dim actsh As Global.Microsoft.Office.Interop.Excel.Worksheet = Globals.ThisAddIn.Application.ActiveSheet
            s2 = bitmat.getEnclosingRectangle

            Dim btmp As New Bitmap(s2(2) + 4, s2(3) + 4)
            For i As Integer = -2 To s2(2) + 1
                For j As Integer = -2 To s2(3) + 1
                    If i >= 0 And i < s2(2) And j >= 0 And j < s2(3) Then
                        If bitmat.Item(i + s2(0), j + s2(1)) Then
                            btmp.SetPixel(i + 2, j + 2, color:=Color.Black)
                        Else
                            btmp.SetPixel(i + 2, j + 2, color:=Color.White)
                        End If
                    Else
                        Try
                            btmp.SetPixel(i + 2, j + 2, color:=Color.White)
                        Catch exx As Exception
                            MsgBox(exx.Message & i & j)
                        End Try
                    End If
                Next
            Next
#If DEBUG Then

#End If
            'bitmap1 = bw.Write(bitmat)
            If My.Settings.changeSize Then
                bitmap1 = New Bitmap(btmp, Math.Max(My.Settings.size, s2(2) + 4), Math.Max(My.Settings.size, s2(3)) + 4)
            Else
                bitmap1 = btmp
            End If
            System.Windows.Forms.Clipboard.SetDataObject(bitmap1, True)
            actsh.Paste(app.ActiveCell, bitmap1)
            app = Nothing
            img = Nothing
            bw = Nothing
        Catch ex As Exception
            MsgBox(ex.Message)
            app = Nothing
            img = Nothing
            bw = Nothing
        End Try


    End Sub

    Private Sub DropDown1_SelectionChanged(sender As Object, e As RibbonControlEventArgs) Handles DropDown1.SelectionChanged
        My.Settings.Level = DropDown1.SelectedItemIndex
        My.Settings.Save()
#If DEBUG Then
        My.Settings.Reload()
        MsgBox(My.Settings.Level)
#End If
    End Sub

    Private Sub DropDown1_ItemsLoading(sender As Object, e As RibbonControlEventArgs) Handles DropDown1.ItemsLoading

    End Sub

    Private Function getDisableEci() As Boolean
        getDisableEci = My.Settings.disable_eci
    End Function
    Private Function getErrorCurrentLevel() As ZXing.QrCode.Internal.ErrorCorrectionLevel
        Select Case My.Settings.Level
            Case 0
                getErrorCurrentLevel = ErrorCorrectionLevel.L
            Case 1
                getErrorCurrentLevel = ErrorCorrectionLevel.M
            Case 2
                getErrorCurrentLevel = ErrorCorrectionLevel.Q
            Case 3
                getErrorCurrentLevel = ErrorCorrectionLevel.H
            Case Else
                getErrorCurrentLevel = ErrorCorrectionLevel.H
        End Select
    End Function

    Private Sub EditBox1_TextChanged(sender As Object, e As RibbonControlEventArgs) Handles EditBox1.TextChanged

        Dim i As Integer, chr As Char(), j As String
        j = ""

        chr = EditBox1.Text.ToCharArray()
        For i = LBound(chr) To UBound(chr)
            If IsNumeric(chr(i)) Then
                j = j & chr(i)
            End If
        Next
        If String.IsNullOrEmpty(j) Then
            EditBox1.Text = My.Settings.size
        Else
            EditBox1.Text = Math.Max(Math.Min(1024, CInt(j)), 21)
            My.Settings.size = Math.Max(Math.Min(1024, CInt(j)), 21)
            My.Settings.Save()
        End If
    End Sub

    Private Sub ComboBox1_TextChanged(sender As Object, e As RibbonControlEventArgs) Handles ComboBox1.TextChanged
        If IsNumeric(ComboBox1.Text) Then
            If CInt(ComboBox1.Text) >= 1 And CInt(ComboBox1.Text) <= 40 Then
                ComboBox1.Text = CInt(ComboBox1.Text)
            Else
                ComboBox1.Text = My.Settings.version
            End If
        End If
    End Sub

    Private Sub CheckBox1_Click(sender As Object, e As RibbonControlEventArgs) Handles CheckBox1.Click
        If CheckBox1.Checked Then
            EditBox1.Enabled = True
        Else
            EditBox1.Enabled = False
        End If
        My.Settings.changeSize = CheckBox1.Checked
        My.Settings.Save()
    End Sub
End Class
Public Class Form1
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load

        TextBox1.Text = Globals.ThisAddIn.Application.ActiveCell.Text
    End Sub

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        MyBase.Hide()
    End Sub
End Class

链接: https://pan.baidu.com/s/1TzaWjwKlHAjYEDKOcgS-fw 提取码: q2xu

本站小水管:excelQRcode_1.0.0.5

分类
excel知识日志

Excel应用——2018河南高考志愿填报

2015年,阁主的亲戚高考。高考完毕,亲人想让我给一些志愿填报的参考意见。但阁主毕竟不是教育行业,所了解的也仅仅是个别学校。如何相对全面的了解各个学校的招生录取情况,来为填报志愿做一个相对较好的选择,成为了摆在面前的一道题。

在收集资料过程中,阁主发现虽然每年高考成绩的分数线各不相同,但由于考生数量和招生计划的比例一般不会发生突变。而河南省由估分报志愿改为查分报志愿之后,高考估分偏差引起的录取不确定性被消除。因此可以用提档线人数占总考生人数比值来估计高校的热门程度,和录取的可能性。于是,阁主就制作了一份包含有3年历史数据的高考分数段分析表,期望能够给亲戚的志愿选择上提供一些参考。

自2015年起,阁主每年都会更新表格中数据,并作出分析图,发布到网络上,希望能够帮助到需要的弟弟妹妹们。

2018年河南理科高考分数段分析及志愿填报参考

分类
VBA

VBA调试——逐语句/逐过程/跳出

VBA作为excel的三大神器之一,初学者经常会遇到各种错误无从下手。语法错误好解决,有些程序逻辑上的错误就需要慢慢调试,慢慢培养思维习惯了。而调试VBA代码,是发现错误,分析错误,解决错误的重要一环。

诸多VBA课程都侧重于从语法/小练习/小案例上开始讲起,这当然便于循序渐进,保持学习兴趣,但是排查错误作为编制程序,尤其是新手编制程序必经的一环,大都放在最后捎带脚提一下,阁主觉得有必要在这里对VBA的调试功能做个简单的介绍,尽量让对VBA感兴趣的朋友可以独立排除程序中的错误。

阁主在这里说下 逐语句/逐过程/跳出 三个调试指令在使用过程中的区别。

逐语句:以单个语句为单位,逐条执行.
遇到调用的自定义子函数或子过程,会进入子过程和子函数逐条执行。

逐过程:在光标所在过程以单个语句为单位,逐条执行.
遇到调用自定义子函数或子过程,会自动执行到子函数或子过程返回后的下一条语句。

跳出:光标所在过程执行到返回上一层。

'“逐语句/逐过程/跳出”三个调试指令的区别
Sub caller()                        '父过程            ①

    Debug.Print "调用子过程callee开始" '                ②
    
    callee                          '调用子过程        ③ 
    
    Debug.Print "调用子过程callee结束"  '              ④
    
End Sub                                '             ⑤

Sub callee(Optional ByVal time = 5) '子过程           ⑥

    Debug.Print time                '                ⑦   
    
End Sub                             '                ⑧

'主要说的是逐语句/逐过程/跳出 三个调试指令在使用过程中的区别。

'逐语句:以单个语句为单位,逐条执行.
'        遇到调用的自定义子函数或子过程,会进入子过程和子函数逐条执行。
'         ①②③(⑥⑦⑧)④⑤

'逐过程:在光标所在过程以单个语句为单位,逐条执行.
'        遇到调用自定义子函数或子过程,会自动执行到子函数或子过程返回后的下一条语句。
'        ①②③④⑤

'跳出:光标所在过程执行到返回上一层。

'        ①②③(⑥⑦(跳出)④⑤

 

分类
VBA

VBA应用——按颜色求和

阁主在工作中,偶尔会碰到需要对标记颜色后的数据进行求和的情况,但是EXCEL中又没有合适的函数可以用来进行按颜色求和,于是,阁主用VBA写了一个函数,以后用起来就方便了。

使用方法:

1、打开VBA编辑器。开发工具→Visual Basic。开发工具栏默认不显示,在选项中设置其可见。

2、插入模块。打开Visual Basic编辑器后,插入→模块,双击新插入的模块打开代码编辑窗口。

3、粘贴代码。复制下方代码粘贴到代码编辑窗口

4、在单元格中调用函数。函数有两个参数,第一个是需要求和的区域,第二个参数为求和所参照的颜色标准。

=SUMCOLOR(A1:D10,A1)

 

Public Function SUMCOLOR(CEL As Range, CEL2 As Range)
    Dim s As Range
    For Each s In CEL
        If s.Interior.Color = CEL2.Interior.Color Then
            SUMCOLOR = SUMCOLOR + s.Value
        End If
    Next
End Function
Public Function CELLCOLOR(CEL As Range)
    Dim colorArray()
    ReDim colorArray(CEL.Rows.Count - 1, CEL.Columns.Count - 1)
    For i = 0 To UBound(colorArray)
        For j = 0 To UBound(colorArray, 2)
            colorArray(i, j) = CEL.Cells(i + 1, j + 1).Interior.Color
        Next
    Next
    CELLCOLOR = colorArray
End Function

 

分类
VBA

VBA应用——记录更改履历

阁主在工作过程中,用excel编制一些文件,需要记录变更履历。而excel没有一个方便的版本管理工具,阁主就想到了excel自带的vba环境。何不自己写一个出来呢?

先来说说编程思路,思路对了,程序就出来了一半。

首先,我们记录更改履历,就需要记录原值,而excel工作簿和工作表的change事件不能返回原值,所以阁主采用了一个取巧的办法,当然,在使用时候就有了限制。

软件思路

①更改发生,产生change事件,并伴随参数target和sh,target是变更的区域,sh是变更的工作表。

②worksheet的change事件代码运行。这时,可以获取到更改区域和更改后的值,将更改后的值存放到数组中以备用。

③调用application.undo方法。该方法放弃修改后的新值并返回原值。将原值存入数组。

④再次调用application.undo方法。恢复目标区域的值为修改后的值。

⑤将获取到的值写入变更履历工作表中

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim TimeFormatString As String
    Dim TimeStamp As String
    Const VersionControlSheetName = "版本控制"
    '版本控制页名称有更改的,请变更此常量
    
    TimeFormatString = "yyyy-mmm-dd HH:mm:ss"
    '时间戳文本格式
    
    Dim AvailableZone As String
    AvailableZone = "A1:Q42"
    '有效区域地址
    
    If Application.Union(Target, Range(AvailableZone)).Address = Range(AvailableZone).Address Then
         TimeStamp = Format(Now, TimeFormatString)
         '
         '
         
         Dim enableEventsFlag As Boolean
         enableEventsFlag = Application.EnableEvents
         Application.EnableEvents = False
         '防止循环调用
         
         If Target.Areas.Count > 1 Then
             '多重区域无效
             MsgBox ("只能选择单一区域进行更改")
             Application.Undo
        ' ElseIf Target.MergeCells Then
        '     MsgBox "不能用于合并单元格!"
        '     Application.Undo
         ElseIf Sh.Name <> VersionControlSheetName Then
             Dim newValue(), oldVaue(), rNum, cNum, rNums, cNums
             Dim actcel As Range
             Set actcel = ActiveCell
             rNums = Target.Rows.Count
             cNums = Target.Columns.Count
             '获取目标区域大小
             
             ReDim newValue(1 To rNums, 1 To cNums)
             
             For rNum = 1 To rNums
                 For cNum = 1 To cNums
                     newValue(rNum, cNum) = Target.Cells(rNum, cNum).Formula
                 Next
             Next
             '获取目标修改后区域值
             
             Application.Undo
             
             ReDim oldvalue(1 To rNums, 1 To cNums)
             
             For rNum = 1 To rNums
                 For cNum = 1 To cNums
                     oldvalue(rNum, cNum) = Target.Cells(rNum, cNum).Formula
                 Next
             Next
             '获取目标修改前区域值
             
             Application.Undo
             Dim arr(), m
             m = 0
             For rNum = 1 To rNums
                 For cNum = 1 To cNums
                     If (oldvalue(rNum, cNum) <> "" Or newValue(rNum, cNum) <> "") And (oldvalue(rNum, cNum) <> newValue(rNum, cNum)) Then
                         m = m + 1
                         ReDim Preserve arr(1 To 5, 1 To m)
                         arr(1, m) = TimeStamp
                         '时间戳
                         arr(2, m) = "=hyperlink(""#" & Sh.Name & "!" & Target.Cells(rNum, cNum).Address & """,""" & Sh.Name & "!" & Target.Cells(rNum, cNum).Address & """)"
                         '变更位置链接链接
                         arr(3, m) = oldvalue(rNum, cNum)
                         '变更前值
                         arr(4, m) = newValue(rNum, cNum)
                         '变更后值
                     End If
                 Next
             Next
             Dim arr2
             If m > 0 Then
                 arr2 = Application.WorksheetFunction.Transpose(arr)
                 Sheets(VersionControlSheetName).Range("A65535").End(xlUp).Resize(UBound(arr, 2), UBound(arr)).Offset(1, 0) = arr2
             End If
             '处理并输出版本控制内容
             
             actcel.Activate
             
         End If
             
         Application.EnableEvents = enableEventsFlag
    End If
End Sub

更改履历能够处理的是使用者的键入、删除、更改操作,对于执行vba或者其他方面造成的更改无法记录。这是源于阁主使用了application.undo方法来获取更改位置的原值。而vba等操作过的数据,该方法不适用。