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

Excel完美论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

快捷登录

 
版块
版块
班级
班级
班级
班级
其它
其它
查看: 8071|回复: 23

[原创] 佛山小老鼠带您走进字典(编程字典入门帖)

  [复制链接]

1万

积分

17

技术分

509

鲜花

管理员

佛山小老鼠

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

财富币
737125
学费币
3220
推广币
228614
学员红花
0
注册时间
2014-12-17

管理员基础技巧讲师函数讲师VBA编程讲师 透视表讲师

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2014-12-20 03:10:26 | 显示全部楼层 |阅读模式
一键分享 一键分享
佛山小老鼠带您走进字典(编程字典入门帖)

大家好,清晨2点了,好久没有在论坛写东西了,把本人近一段时间学习字典的心得写出来,高手就飘过,菜鸟级,入门的朋友和我一同来.当然有说的不对的中央,请大家指正.谢谢,声明我不是高手,由于我看过论坛一些朋友写的字典,我也看不懂,真是羡慕他们.下面是我对字典学习一些心得分享给想理解学习这方面的朋友.

一、字典的作用

1.由于字典的关键词具有独一性,所以字典有去重的作用,应用到按列拆分红工作表,按列拆分红工作簿,后面我们在应用的案列中讲解

2.由于字典里一个关键字对应着一个条目,我们经常用条目来编号,别离数组,应用案例有分类汇总,后面我们也用一个案例来讲解

3.速度快,在代码中用来提速

二、援用字典的方法(字典不是Excel程序里对象,是外部对象)

1.前期绑定:方法 Alt+F11 翻开VBE编辑窗口-->工具菜单-->援用-->阅读-->找到scrrun.dll-->选择它-->翻开-->肯定

  Sub 前期绑定()
                     Dim dic As New Dictionary
              End Sub

2.后期绑定

sub 后期绑定()

  Dim dic

Set dic= CreateObject("Scripting.Dictionary")

End Sub

两者的区别,前期绑定优点会弹出列表,当您输入dic.之后,后面会弹出成员列,6个方法和4个属性,便当入门的朋友学习,缺陷就是把带有字典代码的工作簿发给朋友,朋友不能直接用,也要像前面讲的一样----Alt+F11 翻开VBE编辑窗口-->工具菜单-->援用-->阅读-->找到scrrun.dll-->选择它-->翻开-->肯定,这样就给不会VBA用户带来极不便当.恰恰 相反的,后期绑定的优点就是前期绑定的缺陷,后期绑定的缺陷就是前期绑定的优点为,因此建议大家两都别离起来,假设你是新手的朋友,前期绑定把代码写好之后,最后再用后期绑定发给朋友.


三、字典的6个方法4个属性

dic.Add '添加关键词,方法
            dic.CompareMode = 1'不区分大小写,假设等于0区分大小写
           dic.Count '数字典里的关键词有多少个
           dic.Exists '判别关键词在字典里能否存在
           dic.Item '是指条目
          dic.Key '是指关键词
          dic.Items '可以返回一切条目的集合,也可以说返回一个从0开端编号的一维数组,是方法,大家不要理解为属性,不能当作对象
          dic.Keys '可以返回一切的关键字词集合,也可以说返回一个从0开端编号的一维数组,也是方法
          dic.Remove '肃清某一个关键词
         dic.RemoveAll '肃清全部关键词,而数组只能肃清数组的值,但不是不能清数组空间构造
       而字典里的这个Removeall可以肃清的构造和值,6个方法4个属性详细我们用实例来学习它,今晚写到这里,下次见。




 

                                                  

第1个案例多行多列汇总.rar

14.04 KB, 下载次数: 432

第2个案例用字典做查询表.rar

10.55 KB, 下载次数: 372

第3个实例透视表式的字典.rar

13.66 KB, 下载次数: 381

第4个案例按列拆分成工作簿.rar

15.17 KB, 下载次数: 383

字典里的6个方法和4个属性.rar

16.75 KB, 下载次数: 306


手机扫码浏览
问题咨询交流,不在线时,可以加我微信,微信号18664243619
函数、VBA、透视表交流学习QQ群2801--7317--4,我的电话18664243619,我的QQ732243800,更多的学习也可以关注我们的公众号:vba18664243619
回复

使用道具 举报

1万

积分

17

技术分

509

鲜花

管理员

佛山小老鼠

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

财富币
737125
学费币
3220
推广币
228614
学员红花
0
注册时间
2014-12-17

管理员基础技巧讲师函数讲师VBA编程讲师 透视表讲师

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2014-12-20 03:13:19 | 显示全部楼层
6个方法和4个属性
起床了,起床了,太阳晒屁股了,今天我们把6个方法和4个属性学习完
1.方法add 是添加的意义
Sub test1() '给字典添加关键词和条目
'格式  字典对象+空格 +点号+add+空格+关键词+逗号+条目
  Dim dic
  Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
  With dic
     .Add "不及格", 0
     .Add "及格", 60
     .Add "良好", 70
     .Add "优秀", 80
   End With
End Sub
备注:'把上面的代码复制到模块里,大家一定要学会在本地窗口查看,这个是学习VBA的机密,相当于学习数组函数要会按F9一样查看运算的结果,记住,千万要记住,普通人我不通知的,呵呵,开了一下玩笑,把光标点到代码任何一行,视图
'菜单,本地窗口,F8逐渐运转,大家可以看到关键词在不时增加,这里我没有用循环语句,当然在我们真正把数据装入关键词和条目会用到循环语句 ,有的朋友可能会说,我还没有理解这种装法,其实大家可以把字典看作多行二列的二维数组一样,一列是关键词,一列是条目,有时我们条目不装,为空,可以写成下面这样的

Sub Test2()'条目为空
Dim dic
  Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
  With dic
     .Add "不及格", ""

     .Add "及格", ""
     .Add "良好", ""
     .Add "优秀", ""
   End With
End Sub

如今我们来提一个问:假设要装入字典关键词反复会呈现一个什么现象呢? 如
Sub Test2()'关键词反复会报错
Dim dic
  Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
  With dic
     .Add "不及格", ""

    .Add "不及格", ""
  End With
End Sub
我们运转上面
的代码发现,反复装入关键字会报错,那怎样办呢,难道放在一边,让它凉拌,当然不是呢,在写程序时,有的错误是防止不了的,那我们就要想起这一句On Error Resume Next
Sub Test3() '处理了关键词反复会报错
    Dim dic
    On Error Resume Next
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    With dic
    .Add "不及格", ""
    .Add "不及格", ""
    End With
    On Error GoTo 0 '假设后面的代码有错,让它继续报错
End Sub
这里啰嗦一个On Error Resume Next这一句,好用少用,为什么呢,假设你不在用完它后添加一句On Error GoTo 0,后面有错误它也把错误忽略掉了,这样就不便于大家找错,也就是错了也不会提示你,所以新手要留意这个,除了用这种方法装入字典关键词和条目还有一种方法

格式 字典对象(关键字)=条目
Sub test4() '另一种方法添加关键词和条目
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic("不及格") = 0
    dic("不及格") = 0
    dic("及格") = 60
End Sub
第二种方法添加我是这样理解的,或许我理解错了,dic("不及格") = 0,完好的语句应该是修正条目,由于修正条目的关键词不存在,会自动添加关键词,假设存在就会掩盖原来的,这样就会报错了,只是掩盖,完好的语句如下

dic.Item("不及格") = 0,省略了一个点号和一个item
有的朋友可能会问?
这两种有什么区别呢?
答案是肯定的,肯定有区别,区别大着呢,第一种方法是获得一个呈现的,再呈现反复的装不进去的,第二种方法是获得最后一次的呈现的,前面呈现会被掩盖.包括条目
因此应用它们的区别,我们可以应用到查找最后一次进货的和第一次出货的日期,当然前提条件我们的日期是排序的
吃饭了,吃饭了,吃饭时间到了,这一楼还没有完工,有空再继续……

=========================================================

我们接着上面继续
2.Count属性:前面我们讲过,它可以统计关键词的个数
Sub test5() '
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic("不及格") = 0
    dic("不及格") = 0
    dic("及格") = 60
    MsgBox dic.Count
End Sub
大家运转代码,结果显现2,也就是说字典dic里的关键是2个,不是3个,上面我们讲过,因此字典有去重作用
3.Keys方法
4.Item方法
Keys的作用是把关键词从字典里读出来,普通我们把它赋一个数组,这个数组是一维的,且它的第一个编号是0,也就是它的上标是从0开端的
Items的作用是把条目从字典里读出来,普通我们把它赋一个数组,这个数组是一维的,且它的第一个编号是0,也就是它的上标是从0开端的
详细我们看一个实例
Sub test6() '考证Keys和Items方法
    Dim dic, arr1, arr2
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic("不及格") = 0
    dic("不及格") = 0
    dic("及格") = 60
    arr1 = dic.Keys '把字典里的一切关键词赋值给数组arr1
    arr2 = dic.Items '把字典里的一切条目赋值给数组arr2
   With Sheets("keys和Items")
        .[A1].Resize(dic.Count, 1) = Application.Transpose(arr1)
        .[B1].Resize(dic.Count, 1) = Application.Transpose(arr2)
        '上面的代码为什么要转,由于经过keys和Items方法读到数组都是一维的
        '假设读到单元格是横向的就不用转置,由于是纵向的,所以调用工作表内置数
        'Transpose函数转置一下
    End With
End Sub
接下来我们讲解2个自定义函数
一个是统计区域独一值的个数
一个是去重函数

Function 计数(Rg As Range)
    Dim dic, arr1, ar
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    arr1 = Rg '把单元格区域装入到数组arr1里,由于装到数组里速度快一些
    For Each ar In arr1
        If ar <> "" Then ' 扫除空单元格
            dic(ar) = "" ' 把数组arr1里的每一个元素依次装进字典dic里,停止去重
        End If
    Next ar
    计数 = dic.Count'把结果赋值给函数名'
End Function

Function 去重(Rg As Range, x As Integer)
    Dim dic, arr1, ar
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    arr1 = Rg '把单元格区域装入到数组arr1里,由于装到数组里速度快一些
    For Each ar In arr1
        If ar <> "" Then ' 扫除空单元格
            dic(ar) = "" ' 把数组arr1里的每一个元素依次装进字典dic里,停止去重
        End If
    Next ar
    arr1 = dic.Keys
    If x <= dic.Count Then '假设函数的第二参数小于等于字典里的关键词个数,那么
        去重 = arr1(x - 1) '把数组arr1(x)这个元素赋值给函数去重
    Else '否则函数去重的值为空
        去重 = ""
    End If
End Function
' 备注,自定义去重这个函数,第一参数是单元格区域,且要加绝对援用,可以是多行多列,
'好过我们函数写的那个长长的去重公式,第二参数,假设大家是下拉就要用Row(A1),
'如=去重($A$1:$B$4,ROW(A1))
'假设右拉就用借助Column (A1)
5.方法Exists,判别关键词在字典里能否存在

Sub test7() 'Exists方法
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic("不及格") = 0
    dic("不及格") = 0
    dic("及格") = 60
    If dic.Exists("不及格") Then '判别"不及格"关键词能否存在
        MsgBox "不及格--关键词存在"
    Else
      MsgBox "不及格--关键词不存在"
    End If
    If dic.Exists("优秀") Then '判别"不及格"关键词能否存在
        MsgBox "优秀--关键词存在"
    Else
      MsgBox "优秀--关键词不存在"
    End If
End Sub

6、Remove,肃清字典里某一个关键词,且还肃清其构造,而数组里的Erase,只能肃清其值,不能肃清数组空间构造
格式 dic.Remove "某一个关键词"
7'RemoveAll肃清字典里一切关键词,且还肃清其构造
格式 dic.RemoveAll
Sub test8() '方法Remove和RemoveAll
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic("不及格") = 0
    dic("不及格") = 0
    dic("及格") = 60
    dic("良好") = 70
    dic("优秀") = 80
    MsgBox dic.Count '显现字典里有4个关键词
    dic.Remove "不及格"
    MsgBox dic.Count '显现字典里有3个关键词,由于关键词"不及格"被删除了
    dic.RemoveAll '显现字典里有0个关键词,由于关键词全部被删除了
    MsgBox dic.Count
End Sub
8、Key 属性,修正字典里的关键词

9、Item属性,修正字典里的某关键词的条目
Sub test9() '属性Key和Item
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic("不及格") = 0
    dic.Key("不及格") = "D" '把关键词"不及格"修正为"D"
    dic.Item("D") = 59 '把关键词"D"的条目修正为59
End Sub

备注:至于在本地窗口的变化,本人去查看,我不再多说了
10.'CompareMode '属性 比拟方式 如 Dic.CompareMode=1不区分大小写,Dic.CompareMode=0区分大小写
Sub test10() '区分大小写,默许不写是区分的,因此我们只需在不区分时才补上这句
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic.Add "D", 0
    dic.Add "d", 0
    '由于默许的是区域大小写的,所以不报错
End Sub
Sub test11() '不区分大小写,
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典对象
    dic.CompareMode = 1
    dic.Add "D", 0
    dic.Add "d", 0
    '上面的代码报错了,由于dic.CompareMode = 1不区分大小写,所以
    '你装后大写的D之后,再装小写的d,重装了,报错
End Sub

==========================================================
6个方法和4个属性我们就讲完了,谢谢大家,后面我们用大家在工作常用的实例来讲解,这一楼我们的讲解完毕了,附件在1楼,待续中……,下次见


问题咨询交流,不在线时,可以加我微信,微信号18664243619
函数、VBA、透视表交流学习QQ群2801--7317--4,我的电话18664243619,我的QQ732243800,更多的学习也可以关注我们的公众号:vba18664243619
回复 支持 反对

使用道具 举报

1万

积分

17

技术分

509

鲜花

管理员

佛山小老鼠

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

财富币
737125
学费币
3220
推广币
228614
学员红花
0
注册时间
2014-12-17

管理员基础技巧讲师函数讲师VBA编程讲师 透视表讲师

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2014-12-20 03:14:18 | 显示全部楼层
第一个案例:
1.多行2列分类汇总
2.多行多列分类汇总
Option Explicit
Sub 二列多行()
    Dim arr1, dic, x, arr2(1 To 10, 1 To 2), m%, k% '定义变量
    Set dic = CreateObject("Scripting.dictionary") '后期绑定援用字典
    arr1 = Range("A1").CurrentRegion '把单元区域装到数组arr1
    For x = 2 To UBound(arr1, 1) '循环数组arr1的行
       If dic.exists(arr1(x, 1)) Then '判别数组元素arr1(x,1)在字典关键词里能否存在,
           m = dic(arr1(x, 1)) '假设存在,把关键词arr1(x,1)的条目读出来,在原来的
       '根底上累加,经过读取关键词arr1(x,1)的条目,找到在数组arr2那一行上累加
           arr2(m, 2) = arr2(m, 2) + arr1(x, 2) '在数组arr2第m行,第2列上累加
       Else '假设关键词arr1(x,1)不存在,那么
            k = k + 1 '计数
            dic(arr1(x, 1)) = k '把数组arr1(x,1)装到字典dic里,条目装一个k,
            '这个k的作用来给数组arr2中找到存放那一行
            arr2(k, 1) = arr1(x, 1) '把数组arr1里的第x行第1列装到数组arr2的第k行,第1列
            arr2(k, 2) = arr1(x, 2) '把数组arr1里的第x行第2列装到数组arr2的第k行,第2列
       End If
    Next x
    Range("E1:F" & Rows.Count) = "" '清空区域,用来存放新的数据
    [E1:F1] = Array("产品称号", "数量") '填充表头
    [E2].Resize(k, 2) = arr2 '把数组arr2读到单元格区域
End Sub

Sub 多列多行汇总()
    Dim dic, arr1, x%, MySt, k%, arr2(1 To 15, 1 To 3), y%, m%
    Set dic = CreateObject("Scripting.dictionary")
    arr1 = Range("A1").CurrentRegion
    For x = 2 To UBound(arr1, 1)
        MySt = arr1(x, 1) & arr1(x, 2)
        If dic.exists(MySt) Then
           m = dic(MySt)
           arr2(m, 3) = arr2(m, 3) + arr1(x, 3)
        Else
            k = k + 1
            dic(MySt) = k
            For y = 1 To 3
                arr2(k, y) = arr1(x, y)
            Next y
        End If
    Next x
    Range("E1:G" & Rows.Count) = ""
    [E1:G1] = Array("产品称号", "款号", "数量")
    [E2].Resize(k, 3) = arr2
End Sub

Sub 清空1()
    Range("E1:F" & Rows.Count) = ""
End Sub

Sub 清空2()
    Range("E1:G" & Rows.Count) = ""
End Sub
复制代码第二个代码我就不加注解了,同第一个代码差不多,区别是
由于关键字只能装1列,假设有多列怎样办呢?
我们可以把多列用&串起来,多串字符串就变成了一串字符串
附件在第1楼

问题咨询交流,不在线时,可以加我微信,微信号18664243619
函数、VBA、透视表交流学习QQ群2801--7317--4,我的电话18664243619,我的QQ732243800,更多的学习也可以关注我们的公众号:vba18664243619
回复 支持 反对

使用道具 举报

1万

积分

17

技术分

509

鲜花

管理员

佛山小老鼠

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

财富币
737125
学费币
3220
推广币
228614
学员红花
0
注册时间
2014-12-17

管理员基础技巧讲师函数讲师VBA编程讲师 透视表讲师

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2014-12-20 03:15:10 | 显示全部楼层
第二个案例用字典做查询表
Option Explicit
Sub 查询()
    Dim dic, arr1, arr2, arr3, arr4(1 To 100, 1 To 2), x&, y&, k& '定义变量
    Set dic = CreateObject("Scripting.Dictionary") '后期绑定援用字典
    Range("H2:I100") = "" '清空原有的数据
    arr1 = Range("A1").CurrentRegion '把区域装到数组arr1
    arr2 = Range("F1").CurrentRegion '把区域装到数组arr2
    For x = 2 To UBound(arr1, 1) '循环数组arr1的行
        dic(arr1(x, 1) & "|" & arr1(x, 2)) = arr1(x, 3) & "|" & arr1(x, 4)
        '由于两个条件,而关键字只能装一个条件,所以用&把两件条件连起来,中间用"|"分开
        '同理,由于有二个条目,而一个关键词只能对应一个条目,因此我也是用&衔接起来,中间用"|"分开
        '这样就处理了多行多列装入到字典,间接的打破了字典只能装两列
    Next x
    For y = 2 To UBound(arr2, 1) '循环数组arr2的行
        arr3 = VBA.Split(dic(arr2(y, 1) & "|" & arr2(y, 2)), "|")
        '根据arr2(y, 1) & "|" & arr2(y, 2))读字典dic里的条目出来,其实它的条目就是我们
        '方才arr1后面两列的用"|"的数据,然后用函数Split切开,根据"|",赋值给数组arr3
        '大家一定要明白,Split经过"|"切开,赋值给数组arr3 数组arr3是一维数组,且它的上标从0开端
        k = k + 1 '累加k
        arr4(k, 1) = Val(arr3(0)) '把切开出来的数据放到数组arr4里
        arr4(k, 2) = Val(arr3(1))
    Next y
    [H2].Resize(k, 2) = arr4
End Sub
Sub 清空()
     Range("H2:I100") = ""
End Sub
附件在第1楼


评分

参与人数 1鲜花 +2 收起 理由
yy叶子 + 2 优秀帖子

查看全部评分

问题咨询交流,不在线时,可以加我微信,微信号18664243619
函数、VBA、透视表交流学习QQ群2801--7317--4,我的电话18664243619,我的QQ732243800,更多的学习也可以关注我们的公众号:vba18664243619
回复 支持 反对

使用道具 举报

1万

积分

17

技术分

509

鲜花

管理员

佛山小老鼠

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

财富币
737125
学费币
3220
推广币
228614
学员红花
0
注册时间
2014-12-17

管理员基础技巧讲师函数讲师VBA编程讲师 透视表讲师

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2014-12-20 03:17:07 | 显示全部楼层
第三个案例
透视表式的字典

Option Explicit
Sub 透视表式的汇总()
    Dim arr1, dica, dicb, x&, k&, y&, m&, n&, a&, b&, arr2() '定义相关的变量
    Set dica = CreateObject("Scripting.Dictionary") '创立两个字典
    Set dicb = CreateObject("Scripting.Dictionary")
    arr1 = Range("A1").CurrentRegion '把区域装入数组arr1
    For x = 2 To UBound(arr1, 1) '循环数组arr1的行
        If Not dicb.exists(arr1(x, 2)) Then '假设关键字arr1(x,2)不存在,那么
        '就把它装入字典dicb里,目的就是为了去重
            k = k + 1 '累加k,目的给dicb做条目
            dicb(arr1(x, 2)) = k + 1 '这里为什么还要加1呢? 缘由在数组arr2里第一列是产品称号
            '第二放型号"大号",第三列放型号"中号",第四列放型号"小号",第五列是行汇总
        End If
    Next x
    ReDim arr2(1 To 100, 1 To dicb.Count + 2)
    For y = 2 To UBound(arr1, 1)
        If dica.exists(arr1(y, 1)) Then '假设字典dica里关键字arr1(y,1)存在,那么就累加arr2数据列
            a = dica(arr1(y, 1)) '字典dica里关键词arr1(y,1)的条目读出来,目的在是在数组arr2
            '里找到累加数组arr2那一行,而数组arr2有五列,详细累加到那一列呢?
            b = dicb(arr1(y, 2)) '字典dicb里的关键词arr1(y,2)的字典读出来,来定位到详细累加到数组arr2那一列
            arr2(a, b) = arr2(a, b) + arr1(y, 3)
            arr2(a, 5) = arr2(a, 2) + arr2(a, 3) + arr2(a, 4) '同一行三种型号相加
        Else
            m = m + 1 '累加m,目的给dica做条目和数组arr2定位
            dica(arr1(y, 1)) = m '把arr1(y,1)装入字典dic2,条目为m
            n = dicb(arr1(y, 2))
            arr2(m, 1) = arr1(y, 1) '把数组arr1的第一列装入arr2里的第一列
            arr2(m, n) = arr1(y, 3) '把数组arr1的第三列装入arr2里的第n列
        End If
    Next y
    Range("F1:J" & Rows.Count) = ""
    [F1] = "产品称号"
    [G1].Resize(1, dicb.Count) = dicb.keys
    [G1].Offset(0, dicb.Count) = "行合计"
    [F2].Resize(dica.Count, dicb.Count + 2) = arr2
End Sub
Sub 清空()
   Range("F1:J" & Rows.Count) = ""
End Sub
附件在第1楼

问题咨询交流,不在线时,可以加我微信,微信号18664243619
函数、VBA、透视表交流学习QQ群2801--7317--4,我的电话18664243619,我的QQ732243800,更多的学习也可以关注我们的公众号:vba18664243619
回复 支持 反对

使用道具 举报

1万

积分

17

技术分

509

鲜花

管理员

佛山小老鼠

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

财富币
737125
学费币
3220
推广币
228614
学员红花
0
注册时间
2014-12-17

管理员基础技巧讲师函数讲师VBA编程讲师 透视表讲师

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
 楼主| 发表于 2014-12-20 03:17:40 | 显示全部楼层
第4个案例
按列拆分红工作表
按列拆分红独立的工作簿

Option Explicit

Sub 按列拆分红工作表()
    Dim x%, Rg As Range, ColNum&, dic, arr1, y&, arr2, z&
    Set dic = CreateObject("scripting.dictionary")
    Sheets("总表").Activate
    For x = Sheets.Count To 2 Step -1 '删除工作表时要从大到小循环
        Application.DisplayAlerts = False '关闭讯问对话框
        Sheets(x).Delete '删除工作表
        Application.DisplayAlerts = True '翻开讯问对话框
    Next x
    '经过InputBox这个方法肯定你要拆分的列
    On Error GoTo 100 '假设有错误跳转到100外
    Set Rg = Application.InputBox("请选择您要拆分的列", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    ColNum = Rg.Column '把要拆分的列赋值变量 ColNum
    On Error GoTo 0 '下面的代码有错误,继续报错
    arr1 = Range("a1").CurrentRegion
        For y = 2 To UBound(arr1)
            If dic(arr1(y, ColNum)) = "" Then
            End If
        Next y
        arr2 = dic.keys '把字典里的关键词一次性赋值给数组arr2,且是一维数组,编号从0开端
        For z = 0 To dic.Count - 1 '循环字典的关键词
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = arr2(z)
            Sheets("总表").Activate '由于新建后活动表会转到最后一个工作表,要重新选择“总表”为活开工作表停止挑选
           Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter ColNum, arr2(z)
            '方法AutoFilter第一参数挑选哪一列,第二参数挑选关键词
             Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).SpecialCells(xlCellTypeVisible).Copy Sheets(Sheets.Count).Range("A1") '定位可见单元格
            '假设那一列是数据化,大家一定要留意,不能用sheets(arr2(z)表示工作表,要用sheets(sheets.count)表示
            '这样程序就通用
        Next z
            Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter
    Exit Sub
100:
    MsgBox "您选择了取消或者是关闭,行将退出程序", 64, "温馨提示"
End Sub
复制代码Option Explicit
Sub 按列拆分红独立的工作簿()
    Dim x%, Rg As Range, ColNum&, dic, arr1, y&, arr2, z&, St, StFile$, a%, b%, wb As Workbook
    Set dic = CreateObject("scripting.dictionary")
    St = Application.FileDialog(msoFileDialogFolderPicker).Show '假设你选择了文件夹就返回-1,不选择文件夹
    '就返回0,相当于你按了取消和关闭按钮
    If St <> 0 Then
        StFile = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
        '获得你选择的那个文件夹途径
    Else
        Exit Sub
    End If
    Sheets("总表").Activate
    For x = Sheets.Count To 2 Step -1 '删除工作表时要从大到小循环
        Application.DisplayAlerts = False '关闭讯问对话框
        Sheets(x).Delete '删除工作表
        Application.DisplayAlerts = True '翻开讯问对话框
    Next x
    '经过InputBox这个方法肯定你要拆分的列
    On Error GoTo 100 '假设有错误跳转到100外
    Set Rg = Application.InputBox("请选择您要拆分的列", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    ColNum = Rg.Column '把要拆分的列赋值变量 ColNum
    On Error GoTo 0 '下面的代码有错误,继续报错
    arr1 = Range("a1").CurrentRegion
        For y = 2 To UBound(arr1)
            If dic(arr1(y, ColNum)) = "" Then
            End If
        Next y
        arr2 = dic.keys '把字典里的关键词一次性赋值给数组arr2,且是一维数组,编号从0开端
        For z = 0 To dic.Count - 1 '循环字典的关键词
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = arr2(z)
            Sheets("总表").Activate '由于新建后活动表会转到最后一个工作表,要重新选择“总表”为活开工作表停止挑选
           Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter ColNum, arr2(z)
            '方法AutoFilter第一参数挑选哪一列,第二参数挑选关键词
             Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).SpecialCells(xlCellTypeVisible).Copy Sheets(Sheets.Count).Range("A1") '定位可见单元格
            '假设那一列是数据化,大家一定要留意,不能用sheets(arr2(z)表示工作表,要用sheets(sheets.count)表示
            '这样程序就通用
        Next z
            Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter '取消挑选
            Application.DisplayAlerts = False '关闭讯问对话框
            For a = 2 To Sheets.Count '循环总表后面的分表
                Sheets(a).Copy '依次复制分表成独立的工作簿
                Set wb = ActiveWorkbook '把分表折成的独立的工作簿设置为活开工作簿
                With wb
                    .SaveAs Filename:=StFile & "\" & Sheets(1).Name & ".xls", FileFormat:=xlExcel8 '把新的工作簿保管为规则的文件夹下
                    .Close True '关闭工作簿,且保管
                End With
            Next a
            For b = Sheets.Count To 2 Step -1 '删除"总表"工作表后面一切工作表
                Sheets(b).Delete
            Next b
             Application.DisplayAlerts = True '翻开讯问对话框
            MsgBox "亲,拆分终了,请查阅", 64, "温馨提示"
            Shell "explorer.exe " & StFile, 1 '显现拆分后的,便于查询,大家要留意义exe后面有一个空格
    Exit Sub
100:
    MsgBox "您选择了取消或者是关闭,行将退出程序", 64, "温馨提示"
End Sub
附件在第1楼

问题咨询交流,不在线时,可以加我微信,微信号18664243619
函数、VBA、透视表交流学习QQ群2801--7317--4,我的电话18664243619,我的QQ732243800,更多的学习也可以关注我们的公众号:vba18664243619
回复 支持 反对

使用道具 举报

591

积分

1

技术分

117

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
5948
学费币
27
推广币
271
学员红花
15
注册时间
2014-12-20

管理员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2014-12-20 23:29:36 | 显示全部楼层
    感谢教师把每句代码都注释得这样清楚,上课时没听懂或者不明白的中央可以到这儿来复习和稳固了。
回复 支持 反对

使用道具 举报

449

积分

1

技术分

48

鲜花

正式学员(完美教育)

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

正式学员

    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2014-12-21 10:56:53 | 显示全部楼层
非常不错,第一次学习字典,谢谢小老鼠教师
回复 支持 反对

使用道具 举报

1204

积分

10

技术分

141

鲜花

版主

Rank: 7Rank: 7Rank: 7

财富币
17078
学费币
139
推广币
2575
学员红花
0
注册时间
2014-12-18

管理员

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

使用道具 举报

251

积分

0

技术分

0

鲜花

初级会员

Rank: 2

财富币
2792
学费币
0
推广币
0
学员红花
0
注册时间
2014-12-21
    购买在线课件和视频
    报班咨询联系电话
    Tel:186-6424-3619
    联系人:佛山小老鼠
    在线网络开设YY班级
    函数初级班
    函数中级班
    函数高级班
    VBA编程初级班
    VBA编程中级班
    VBA编程高级班
    透视表班
    290集视频
    525集excel视频大全
    189集免费excel视频
发表于 2015-1-13 16:05:59 | 显示全部楼层
感谢教师的字典帖子,有点VBA根底了就来学习!
回复 支持 反对

使用道具 举报

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

本版积分规则 快速回帖:

最近新开的班级:2018-7-28开vba初级班,周二、周四、周六晚上8点到10点上课      立即注册  登录 

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

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

GMT+8, 2018-9-24 15:41 , Processed in 0.343805 second(s), 73 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

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