请选择 进入手机版 | 继续访问电脑版

Excel完美论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

快捷登录

版块
版块
班级
班级
班级
班级
其它
其它
查看: 58931|回复: 370

[分享] VBA编程代码天天有(vba入门学习的好资料)

  [复制链接]

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 13:37:48 | 显示全部楼层 |阅读模式
一键分享 一键分享
     各位朋友大家好,我是阆苑小生,大家可能曾经领会到了VBA的强大魅力,想学习总觉得有点费力,我最开端也是如此,感谢有了教师的教诲及各位朋友的协助才使我从一个完好不懂VBA的大菜鸟变成了略知一点皮毛的小菜鸟。为了同大家交流,特开了这个帖子,叫做代码天天有,是仿照的小老鼠及丫头两位教师的叫法,意在每天赋享一段本人所写过的代码,我以为学习VBA,练习写代码是蛮重要的。帖子里的代码绝大局部是本人所写的,有少局部是学习别人的。这些代码可以说见证了我的生长,不少代码看起来很幼稚,但是都是本人生长的一局部,关于新手来说都是从简单代码动手的,希望能给大家提供一些参考,假设只需有一点可以为大家所用,也就不枉开这个帖子了!同时也希望大家多多提意见!
    分享的内容包括源文件 (供大家测试效果),代码 (加有注释),代码触及范围包括常用VBA的学问各大板块,数组、字典、正则、自定义函数、窗体等都包括!  代码1
  1. Sub 插入()'一定要先选中一行
  2. For x = 1 To 500 '从1开端循环 这里指要反复停止插入动作500次,只是限定了一个次数而已
  3.     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '插入一行 并向下偏移 可录制宏得到代码
  4.     ActiveCell.Offset(2, 0).EntireRow.Select '活动单元格向下偏移两行,然后再选中整行,偏移两行是为了确保可以每行都插入
  5.     Next x '可用F8逐渐伐试看一下效果
  6. End Sub
  7. Sub 删除()'首先选中一列
  8.     Selection.SpecialCells(xlCellTypeBlanks).Select '定位 空单元格 等于根底操作的定位 F5
  9.     Selection.EntireRow.Delete '删掉空行
  10. End Sub
复制代码
插入 删除空行.rar (19.2 KB, 下载次数: 722)

评分

参与人数 17财富币 +130 鲜花 +33 收起 理由
石老大 + 1 感谢对完美的支持
青苹果 + 1 优秀帖子
蓝砂 + 10 + 2 优秀帖子
建群不管事 + 10 + 2 支持原创
lslly + 1 优秀帖子
厚德载物 + 2
Ionelyの、殇 + 2 优秀帖子
蓝铃‭ + 2 支持分享
小竹 + 1 支持分享
maomao + 2 优秀帖子
josam444 + 1 支持分享
txyan1020 + 1 支持分享
xuluoyan + 1 支持分享
L-L-X + 2 支持小生版主,猴赛雷。
斌之樊篱 + 1 支持原创
佛山小老鼠 + 100 + 10 优秀帖子
远仑 + 10 + 1 支持分享

查看全部评分


手机扫码浏览
回复

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-2-3 22:11:46 | 显示全部楼层
  1. Sub 兼并计算()
  2.     Dim path$, wb As Worksheet, arr1(), filename$, k%
  3.     Application.ScreenUpdating = False
  4.     path = ThisWorkbook.path & "\" '获得当前工作薄的途径
  5.     filename = Dir(path & "*.*") '应用dir函数获得 该文件途径下的一个工作薄称号
  6.     Do '应用do loop语句就行循环
  7.         If filename <> ThisWorkbook.Name Then '不能使它获得当前工作薄的称号  不会呈现第一个就是工作薄 就退出的情况
  8.         Workbooks.Open path & filename '要兼并计算的工作薄
  9.         k = k + 1 '翻开一个就记一次数
  10.         ReDim Preserve arr1(1 To k) '重新定义arr1,arr1是用来最后放完好途径和数据的
  11.         arr1(k) = "'" & path & "[" & filename & "]" & Sheets(1).Name & "'!r1c1:r" & Cells(Rows.Count, 1).End(xlUp).Row & "c2"
  12.         '每循环一次,就将完好途径和数据装入数组arr1 构造为 完好的途径+工作薄名+工作表+汇总的数据(必需用r1c1援用表示)
  13.         ActiveWorkbook.Close '关闭活开工作薄,也就是前面循环翻开的工作薄
  14.         End If
  15.         filename = Dir '再一次应用dir获得文件名,这次可以省略后面的途径
  16.     Loop While filename <> "" '退出do loop语句的条件,不为空
  17.     '=======================以上都是获得一切的数据的完好途径,并装入一维数组arr1
  18.     Range("a1").Consolidate arr1, xlSum, True, True '应用兼并计算分类汇总,类似于根底操作中的兼并计算
  19.     '第一参数是要计算的区域,是一个数组方式的文本字符串集合
  20.     '第二参数只兼并计算的类型,这里是求和xlsum,当然还有求最值、均值等等
  21.     '第三四参数指的是能否按首行首列计算,指能否存在行标题和列标题
  22.     '第五参数这里省略,指的是不运用工作表链接
  23.     '有兴味的朋友可用F1查看协助
  24.     Range("a1") = "姓名" '兼并计算的小问题,兼并计算的起始单元格,会是空格,要补上表头
  25.     Application.ScreenUpdating = True
  26. End Sub
  27. Sub 清空()
  28. Range("a:b").Clear
  29. End Sub 2-3 应用兼并计算 汇总多工作薄.rar (38.23 KB, 下载次数: 669)
复制代码
2-3.gif

点评

这个既熟悉又陌生,很好理解  发表于 2016-7-14 20:18
优秀的贴子.给10个赞!  发表于 2015-6-24 09:43

评分

参与人数 6财富币 +20 鲜花 +10 收起 理由
建群不管事 + 10 + 2 支持原创
monit + 1 优秀帖子
Ionelyの、殇 + 1 支持原创
远仑 + 10 + 2 支持原创
浅念旧时光 + 2 支持分享
L-L-X + 2 优秀帖子

查看全部评分

回复 支持 5 反对 0

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-1-31 11:02:02 | 显示全部楼层
  1. Sub test()
  2.     Dim x, s
  3.     For x = 2 To Cells(Rows.Count, 1).End(xlUp).Row '从第二行开端求和
  4.         s = s + Cells(x, 1) '累加求和
  5.         If s > 500 Then Cells(x - 1, 1).Offset(0, 1) = s - Cells(x, 1): x = x - 1: s = 0
  6.         '请求的是求和的不能大于500,则停止判别,假设大于500,则将这个求和结果s减去这个单元格cells(x,1)的值赋给它上一个单元格的右侧
  7.         '此时x要减去1,继续从大于500的那个单元格的上一行循环,不然的话,会漏掉一行值
  8.         's需求归零,表示重新叠加求和
  9.         If x = Cells(Rows.Count, 1).End(xlUp).Row Then Cells(x, 2) = s '这个表示将x同最后一行停止比拟判别,在前面循环的时分这一行循环不到,不管前面是多少,这一行一定有一个汇总的结果
  10.     Next x
  11. End Sub<img src="http://www.excelwm.net/forum.php?mod=image&aid=1065&size=300x300&key=8bbdb523ea6d3520&nocache=yes&type=fixnone" border="0" aid="attachimg_1065" alt="" style="line-height: 1.5;">
复制代码
1-31 一列按照条件汇总求和.rar (13.38 KB, 下载次数: 512)
1-31.gif

评分

参与人数 6鲜花 +8 收起 理由
建群不管事 + 2 支持原创
monit + 1 优秀帖子
swszlm + 1 优秀帖子
L-L-X + 2 解题思路新颖
cnpcwt + 1 支持分享
晨风 + 1 支持分享

查看全部评分

回复 支持 2 反对 0

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-1-25 10:41:47 | 显示全部楼层
本帖最后由 阆苑小生 于 2015-1-25 10:50 编辑
  1. Sub 字典和冒泡排序的别离求最大值()
  2. Dim arr, x&, dic, brr(), k&, rg As Range, t!
  3. t = Timer
  4. Set dic = CreateObject("scripting.dictionary")
  5. arr = Range("a1").CurrentRegion
  6. ReDim brr(1 To UBound(arr), 1 To 4) '定义一个数组,用来存放结果,最多数组arr一样大
  7. For x = 2 To UBound(arr) '循环整个数组区域
  8.     If Not dic.exists(arr(x, 2)) Then '判别的根据是第二列的称号
  9.         k = k + 1
  10.         dic(arr(x, 2)) = k '将k作为条目装入字典之中
  11.         brr(k, 1) = arr(x, 1)
  12.         brr(k, 2) = arr(x, 2)
  13.         brr(k, 3) = arr(x, 3)
  14.         brr(k, 4) = arr(x, 4)
  15.   '=====================上面这是不存在的情况,记一次数,并把结果作为条目值装入字典,用以肯定每个称号在brr中的构造,并把arr对应的结果装土brr
  16.         Else
  17.         '=========以下是存在的情况
  18.         If arr(x, 4) > brr(dic(arr(x, 2)), 4) Then '请求找出的是最大值,那么就用第4列的值同brr中已有的值停止判别,假设大于它,则需求把它装入brr
  19.         '假设小于它,则brr中的曾经满足是最大值,不需求动它
  20.         brr(dic(arr(x, 2)), 1) = arr(x, 1)
  21.         brr(dic(arr(x, 2)), 2) = arr(x, 2)
  22.         brr(dic(arr(x, 2)), 3) = arr(x, 3)
  23.         brr(dic(arr(x, 2)), 4) = arr(x, 4) '把最大值的这4列分别装入到结果数组brr之中
  24.         End If
  25.     End If
  26. Next x
  27. On Error Resume Next
  28.   Set rg = Application.InputBox("请选择要存放的区域所在的起始单元格", "提示", Type:=8) '应用inputbox 选择存放的其实单元格
  29.   If Err.Number <> 0 Then Exit Sub '这个是在没有选择区域下的情况
  30.   rg.Resize(1, 4) = arr
  31.   rg.Offset(1, 0).Resize(k, 4) = brr '读出结果
  32.   rg.Offset(0, 1).Resize(1, 4).EntireColumn.AutoFit
  33.   MsgBox Format(Timer - t, "0.00s")
  34. End Sub 1-25 字典和冒泡排序最大值.rar (1.73 MB, 下载次数: 529)
复制代码
字典求最大值.gif

评分

参与人数 2鲜花 +3 收起 理由
L-L-X + 2
cnpcwt + 1 支持分享

查看全部评分

回复 支持 2 反对 0

使用道具 举报

2209

积分

0

技术分

6

鲜花

金牌会员

Rank: 6Rank: 6

财富币
20295
学费币
21
推广币
85
学员红花
0
注册时间
2014-12-18
    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-2-1 10:18:04 | 显示全部楼层
回复 支持 1 反对 0

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-3-27 16:56:32 | 显示全部楼层
本帖最后由 阆苑小生 于 2015-3-27 17:00 编辑
  1. <span style="line-height: 1.5;">Private Sub CommandButton1_Click()</span>
复制代码
  1.   Dim arr1, x&, k&, arr2()
  2.     arr1 = Range("a1").CurrentRegion '将数据装入arr1
  3.     For x = 1 To UBound(arr1) '循环整个数组
  4.         If arr1(x, 1) = Me.TextBox1.Value Then '假设数组里的值等于文本框里的值 则计数一次
  5.             k = k + 1
  6.             ReDim Preserve arr2(1 To k) '重新定义动态数组
  7.             arr2(k) = arr1(x, 2) '装入数组arr2
  8.         End If
  9.     Next x
  10.     If k = 0 Then MsgBox "单词不存在": Exit Sub 'k=0 则标明 没有对应的词组 弹出不存在的对话框
  11.     Me.ListBox1.List = arr2 '将arr2的结果装入列表框
  12. End Sub
  13. Private Sub UserForm_Terminate()
  14.     界面.Show '翻开窗体界面
  15. End Sub
复制代码

3-27.gif 3-27 单词翻译查询窗体.rar (156.92 KB, 下载次数: 527)
回复 支持 1 反对 0

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-3-26 12:42:40 | 显示全部楼层
  1. Sub test()
  2.     Dim path$, wbname, x%, y%
  3.     Application.ScreenUpdating = False
  4.     With Application.FileDialog(msoFileDialogFolderPicker) '会弹出一个选择的对话框
  5.         .Title = "请选择要显现的文件夹"
  6.         If .Show = -1 Then
  7.             path = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "\", "", "\") '等于-1 则标明选择了一个文件夹
  8.         Else
  9.             Exit Sub '不等于-1 则标明没有选中文件夹 退出
  10.         End If
  11.     End With
  12.     Sheets.Add '增加一个工作表
  13.     [a1] = "工作薄": [b1] = "工作表" ' 分别写入 工作薄 工作表 作为标示
  14.     wbname = Dir(path & "*.xls*") '获得目的文件夹下的excel文件
  15.     Do
  16.     x = ActiveSheet.UsedRange.Rows.Count + 1 '获得数据区域行数的最后一行 并加1
  17.     ActiveSheet.Hyperlinks.Add Cells(x, 1), path & wbname, , wbname, wbname '添加一个超链接
  18.     Workbooks.Open path & wbname '翻开一个工作薄
  19.     For y = 1 To Sheets.Count
  20.         Workbooks(ThisWorkbook.Name).Sheets(1).Cells(x + y, 2) = Sheets(y).Name '将工作表名 装入到本工作薄的第二列
  21.     Next y
  22.     ActiveWorkbook.Close False '关闭
  23.     wbname = Dir '再次应用dir取工作薄名
  24.     Loop While wbname <> ""
  25.     Application.ScreenUpdating = True
  26. End Sub
复制代码
3-26.gif 3-26 提取出一切的工作薄、工作表称号 并添加超链接.rar (18.49 KB, 下载次数: 533)

评分

参与人数 1鲜花 +1 收起 理由
monit + 1 支持原创

查看全部评分

回复 支持 1 反对 0

使用道具 举报

3697

积分

2

技术分

83

鲜花

禁止发言

山高人为峰

财富币
20535
学费币
50
推广币
1692
学员红花
0
注册时间
2014-12-17
    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-3-11 10:59:29 | 显示全部楼层
回复 支持 0 反对 1

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-2-25 10:06:04 | 显示全部楼层
  1. Sub test()
  2.     Dim reg, arr1, x%, arr2(), k%
  3.     arr1 = Range("a1").CurrentRegion
  4.     ReDim arr2(1 To UBound(arr1), 1 To 1) '定义一个同数据源区域一样大的数组arr2
  5.     Set reg = CreateObject("vbscript.regexp") '创立一个正则
  6.     reg.Pattern = "[a-zA-Z]*\d+" '正则的匹配规则,表示是恣意多个字母(从0到n)和至少一个数字的构造
  7.     For x = 2 To UBound(arr1) '循环数组arr1
  8.         k = k + 1 '计数,作为数组arr2的构造判别,也可以直接用x
  9.         arr2(k, 1) = reg.Execute(arr1(x, 4))(0) & "-" & reg.Execute(arr1(x, 5))(0) '把两列的内容分别用正则,由于只需一个适宜的结果,直接取0就可以了
  10.     Next x
  11.     [g2].Resize(k, 1) = arr2 '读出结果
  12. End Sub
复制代码
2-25.gif 2-25 只兼并两列的字母数字 (正则妙用).rar (9.7 KB, 下载次数: 476)

评分

参与人数 1鲜花 +2 收起 理由
L-L-X + 2 支持原创

查看全部评分

回复 支持 1 反对 0

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-2-12 10:46:07 | 显示全部楼层
本帖最后由 阆苑小生 于 2015-2-12 10:58 编辑
  1. Sub 提取独一值之删除反复项法() '不支持Excel 2003
  2.   With Range("c1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
  3.     .Value = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row).Value '将一切信息复制到C列放置结果区域,好比照
  4.     .RemoveDuplicates Array(1, 2), xlYes '提取独一值,表头不参与计算
  5. '===== Range.RemoveDuplicates方法用于删除区域中的反复值,其语法如下:
  6. '=====表达式.RemoveDuplicates(Columns, Header)
  7. '======第一参数表示包含反复信息的列的索引数组,假设没有传送任何内容,则假定一切列都包含反复信息。
  8. '======第二参数表示第一行能否包含标题信息 可以按F1查看协助
  9.   End With
  10. End Sub
  11. Sub 提取独一值之高级挑选法()
  12. '对A1到B列最后一个非空单元格执行高级挑选,挑选时取独一值,挑选结果存放在C1
  13. Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter xlFilterCopy, , Range("c1"), True
  14. '表达式.AdvancedFilter(Action, CriteriaRange, CopyToRange, Unique)
  15. 'Action 必选 XlFilterAction XlFilterAction 的常量之一,用于指定能否就地复制或挑选列表。
  16. 'CriteriaRange 可选 Variant 条件区域。假设省略该参数,则没有条件限制。
  17. 'CopyToRange 可选 Variant 假设 Action 为 xlFilterCopy,则为复制行的目的区域。否则,忽略该参数。
  18. 'Unique 可选 Variant 假设为 True,则只挑选独一记载。假设为 False,则挑选契合条件的一切记载。默许值为 False。
  19. End Sub
  20. Sub 提取独一值之字典法()
  21.     Dim arr, dic, x&, brr, k&
  22.     Set dic = CreateObject("scripting.dictionary")
  23.     arr = Range("a1").CurrentRegion
  24.     ReDim brr(1 To UBound(arr), 1 To 2)
  25.     For x = 1 To UBound(arr)
  26.         If Not dic.exists(arr(x, 1) & arr(x, 2)) Then '将两列衔接起来作为判别的条件
  27.             k = k + 1
  28.             dic(arr(x, 1) & arr(x, 2)) = "" '将它装入字典
  29.         brr(k, 1) = arr(x, 1)
  30.         brr(k, 2) = arr(x, 2) '不反复的装入到结果数组brr之中
  31.         End If
  32.     Next x
  33.     [c1].Resize(k, 2) = brr
  34. End Sub
  35. Sub 清空()
  36.     Range("c:d").Clear
  37. End Sub
复制代码
2-12.gif 2-12 三种方法 提取独一值.rar (678 KB, 下载次数: 610)

评分

参与人数 3鲜花 +4 收起 理由
monit + 1 实用
L-L-X + 2 优秀帖子
cnpcwt + 1 支持分享

查看全部评分

回复 支持 1 反对 0

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-2-8 09:01:39 | 显示全部楼层
  1. Sub 填充()
  2.     Dim dic, x%, y%, z%, arr
  3.      Range("a3:a1000").Clear
  4.     Application.DisplayAlerts = False '兼并单元格会弹窗提示,这个可以关闭
  5.     Set dic = CreateObject("scripting.dictionary")
  6.     Range("e3:e" & Cells(Rows.Count, 5).End(xlUp).Row).Copy [a3] '现将户号复制到第一列
  7.     For x = Cells(Rows.Count, 5).End(xlUp).Row To 3 Step -1 '应用倒循环的方法
  8.         If Cells(x, 1) = Cells(x - 1, 1) Then
  9.             Range(Cells(x, 1), Cells(x - 1, 1)).Merge '兼并单元格的方法
  10.         End If
  11.     Next x
  12.     '===========先将户号相同的停止单元格兼并
  13.     For y = 3 To Cells(Rows.Count, 5).End(xlUp).Row
  14.        If Cells(y, 4) = "户主" Then
  15.            dic(Cells(y, 5).Value) = Cells(y, 3) '应用cells装入字典的时分一定要加value,不然会默许装入单元格
  16.        End If
  17.     Next y
  18.     '=====将户号装入字典之中,并装入对应的姓名,根据是等于“户主”的
  19.     For z = 3 To Cells(Rows.Count, 5).End(xlUp).Row
  20.        If Cells(z, 1) <> "" Then Cells(z, 1) = dic(Cells(z, 1).Value) '将户号交换为户主姓名,应用字典停止反读条目值,这个类似于vlookup的作用
  21.     Next z
  22. End Sub
  23. Sub 清空()
  24.     Range("a3:a1000").Clear
  25. End Sub
复制代码
2-8 VBA法 处理兼并单元格动态填充问题.rar (208.84 KB, 下载次数: 527)

评分

参与人数 2鲜花 +3 收起 理由
monit + 1 支持分享
L-L-X + 2 优秀帖子

查看全部评分

回复 支持 1 反对 0

使用道具 举报

356

积分

1

技术分

1

鲜花

初级会员

Rank: 2

财富币
498
学费币
2
推广币
10
学员红花
0
注册时间
2014-12-17
    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 13:56:53 | 显示全部楼层
在某列前加2014
  1. Sub test()
  2. Dim a, b, y
  3. Dim I%
  4. y = Cells(Rows.Count, 1).End(xlUp).Row
  5. For I = 2 To y
  6. a = Cells(I, 1)
  7. b = "2014" & Cells(I, 1)
  8. Cells(I, 1) = b
  9. Next
  10. End Sub
复制代码

评分

参与人数 1鲜花 +1 收起 理由
L-L-X + 1

查看全部评分

If you want to  good at Excel, you need to repeat, repeat, and repeat.This is the only secret.
回复 支持 1 反对 0

使用道具 举报

138

积分

0

技术分

13

鲜花

初级会员

Rank: 2

财富币
2044
学费币
32
推广币
524
学员红花
0
注册时间
2014-12-17

正式学员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 14:19:55 | 显示全部楼层
15赞

点评

感谢支持!  发表于 2015-1-21 11:37

评分

参与人数 1鲜花 +2 收起 理由
阆苑小生 + 2 感谢回复

查看全部评分

回复

使用道具 举报

449

积分

1

技术分

48

鲜花

正式学员(完美教育)

财富币
5608
学费币
41
推广币
705
学员红花
2
注册时间
2014-12-17

正式学员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 14:21:43 | 显示全部楼层
不错,支持了
回复 支持 反对

使用道具 举报

104

积分

0

技术分

9

鲜花

正式学员(完美教育)

财富币
1086
学费币
11
推广币
35
学员红花
9
注册时间
2014-12-23

正式学员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 14:32:36 | 显示全部楼层
不错,支持了

点评

感谢关注!  发表于 2015-1-21 11:38
回复 支持 反对

使用道具 举报

637

积分

0

技术分

23

鲜花

正式学员(完美教育)

财富币
5438
学费币
7
推广币
59
学员红花
145
注册时间
2014-12-18

正式学员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 15:27:32 | 显示全部楼层
学习,谢谢分享!

点评

谢谢关注  发表于 2015-1-21 11:38
回复 支持 反对

使用道具 举报

2209

积分

0

技术分

6

鲜花

金牌会员

Rank: 6Rank: 6

财富币
20295
学费币
21
推广币
85
学员红花
0
注册时间
2014-12-18
    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-12 15:39:39 | 显示全部楼层
谢谢分享!支持!
回复 支持 反对

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-1-13 09:54:46 | 显示全部楼层
本帖最后由 阆苑小生 于 2015-1-13 09:59 编辑
  1. Sub 删除() '恣意选择一个文件夹 并删除该文件夹下一切文件的第一个工作表的第一行
  2.     Dim x%, St$, myname, Wb As Workbook
  3.     x = Application.FileDialog(msoFileDialogFolderPicker).Show '会弹出让你选择目的文件夹的对话框,并根据你选择的结果得到一个值 把值赋给X
  4.     If x <> 0 Then 'X假设等于-1 即不等于0 则表示曾经选择了一个文件夹 假设等于0 则表示没有选择文件夹
  5.     St = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) '把途径名赋给st 这里会得到你选择的途径
  6.     myname = Dir(St & "\" & "*.*") '应用dir函数获得选择目的文件夹下 的一个文件名 只是得到一个文件名
  7.     Application.DisplayAlerts = False '关闭删除的提示对话框
  8.     Application.ScreenUpdating = False
  9.     Do
  10.     Set Wb = Workbooks.Open(St & "\" & myname) '翻开刚刚得到的文件 并把它赋给对象变量wb 如今曾经成了活开工作薄
  11.     With Wb
  12.             .Sheets(1).Range("1:1").EntireRow.Delete '将第一个工作表 第一行删除
  13.             .Close True '关掉活开工作薄wb
  14.     End With
  15.     myname = Dir '必需求二次循环!!!!不然是不可以循环提取称号的 它会逐渐向下提取文件名 直到为空
  16.     Loop While myname <> "" '这里是规则do loop的条件 当文件名为空时  中止循环 表示曾经取完了目的文件夹下一切文件名
  17.     Else
  18.     Exit Sub '没有选择文件夹 则退出程序 不会执行后面的代码
  19.     End If
  20.     Application.DisplayAlerts = True
  21.     Application.ScreenUpdating = True
  22.     MsgBox "删除终了!"
  23.     Shell "explorer.exe " & St, 1 '删除终了后 翻开 目的文件夹
  24. End Sub 代码2 练习文件夹.rar (49.6 KB, 下载次数: 367)
复制代码
回复 支持 1 反对 0

使用道具 举报

886

积分

0

技术分

13

鲜花

高级会员

Rank: 4

财富币
15824
学费币
93
推广币
1105
学员红花
0
注册时间
2014-12-21
    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-14 08:00:25 | 显示全部楼层
正在VBA路上,学习了,谢谢分享!
回复 支持 反对

使用道具 举报

630

积分

2

技术分

173

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
13663
学费币
23
推广币
3068
学员红花
0
注册时间
2014-12-17

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2015-1-14 10:00:55 | 显示全部楼层
本帖最后由 阆苑小生 于 2015-1-15 10:45 编辑
  1. Sub 金额分列()'一键金额分列
  2.   Dim rg As Range, Str$, k%
  3.   Application.ScreenUpdating = False
  4.   On Error GoTo 提示 '假设选择的区域全部为空,会报错,因此要跳转到提示语句处
  5.   For Each rg In Application.Intersect(Selection, ActiveSheet.UsedRange) 'intersect指的是区域的交集,防止选了些无意义的区域,进步效率
  6.     If Len(rg) > 0 Then  '假设单元格文字长度大于0
  7.       '将单元格数字扩展到100倍并保存0位小数,再应用StrReverse反转字符串,赋值给变量Str
  8.       Str = StrReverse(Format(rg.Value * 100, "0"))
  9.       For k = 1 To 11  '循环单元格数字的每一位(全部假定它们有11位)
  10.         '在右边的单元格中逐位写入数字,当长度缺乏时会自动写入一个空文本
  11.         rg.Offset(0, 12 - k).Value = Mid(Str, k, 1)
  12.         '当k等于字符的长度时+1时,在单元格中加一个人民币符号“¥”
  13.         If k = Len(Str) + 1 Then rg.Offset(0, 12 - k).Value = "¥": Exit For '当k大于字符长度加1时,则在最右边加上"¥",并完毕k循环
  14.       Next k
  15.     End If
  16.   Next rg
  17.   Application.ScreenUpdating = True
  18.   Exit Sub
  19. 提示:
  20. MsgBox "请选择不为空区域", , "小生提示"
  21. End Sub
复制代码
111.gif

金额快速分列.rar

18.69 KB, 下载次数: 424

回复 支持 1 反对 0

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则 快速回帖:

手机微信——扫一扫 关注完美论坛公众号天天收到Excel分享

QQ|微信绑定|Archiver|手机版|Excel完美论坛 ( 粤ICP备14102225号  

GMT+8, 2018-12-17 00:59 , Processed in 0.413884 second(s), 52 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表