vba 判断控件有无_测测你的VBA水平，多条件筛选数据并输出到工作簿！

我的目标：让中国的大学生走出校门的那一刻就已经具备这些office技能，让职场人士能高效使用office为其服务。支持鹏哥，也为自己加油！

下面是一位群友付费请教的问题(感谢愿为知识付费的同学)，这里分享给大家：

上面的数据经过了简化，当然实际数据有很多。 要求： 根据A列和C列的类别筛选数据并输出到新的工作簿，工作簿的名字最好能辨识工作簿里的数据是什么。 比如，A列中菜市场1，对应的C列有属于菜市场1的花生，那就筛选花生的数据输出到新表，名字可以命名为菜市场1+花生，这样通过工作簿的名字就能知道里面是什么数据，菜市场1还对应有萝卜的数据，也要输出的到一个新的工作簿中，命名为菜市场1+萝卜，其它菜市场的数据筛选同上。 如果手动筛选、复制粘贴、另存为是不是会很麻烦呢？ 这种时候就能体现出VBA的优势了，而且用到的VBA知识也是入门级别的，所以你说学点VBA入门知识有用吗？ 想进一步提升Excel水平的同学，强烈建议大家学习下VBA入门教程。 公众号后台菜单中点击云课堂，在云课堂中可以找到VBA教程。 言归正传，我们来看下上面的问题。 最终效果如下： 这里分享两种思路： 一、 按照我们常规的操作，直接筛选，复制，新建一个工作簿，按照两个筛选条件给其命名，然后把内容复制进去，保存关闭，再继续(循环操作)…… 把上面的步骤直接写成VBA代码即可。 筛选会用到Range的AutoFilter方法，即区域的自动筛选，此方法的第一个参数field表示筛选区域，这个好确定，Criteria1表示第一个筛选值，比如菜市场1，也可以添加第二个筛选值Criteria2，比如花生。 问题来了，每次循环操作时筛选值怎么确定呢？ 群里有人想到先循环A列，根据A列的值新建工作簿并命名，当循环出来的值在文件夹中与已有的工作簿名字一样时就继续循环，若不一样，则新建工作簿并命名。 建好工作簿后，循环出每个工作簿名字，根据工作簿的名字到数据源里找到对应的数据复制到本工作簿的工作表里就OK了。 当然上述思路也行得通，通过判断来列出A列不重复的类别并新建工作簿， 每个工作簿的名字就可以作为筛选值Criteria1 ，但是我们的案例筛选值是两个，A列和C列，当然变通下也是可以解决的。 如果大家掌握的字典的技术，就可以把通过字典把A列和C列不重复的值写入字典，然后再循环出来这些唯一的值就是筛选值了，关键是循环出菜市场1时，第二个筛选值怎么知道是花生或萝卜，而没有花菜呢？ 我们可以假设有花菜，第一个筛选值为菜市场1时，C列中不重复的关键字都筛选一遍，最后经过判断有无记录也可以得到想要的数据。根据循环出来的类别新建工作簿，然后把符合条件的数据装进去即可。 这又是一种思路，当然上面这两种思路最基本的方法都是使用了Range的AutoFilter方法，除此之外需要具备的知识点还有; 1、工作簿的新建，工作簿的命名、保存并关闭。 2、Range区域的复制。 3、字典技术。 4、遍历文件名的函数Dir。 5、If判断语句，For循环语句等基本语句结构。 但是都是些基础知识，只要大家认真学习下都可以搞明白。 二、 第一种思路中使用的是自动筛选，其实就是相当于手工筛选，只是用代码控制了基础操作而已，如果数据量大的话，估计运行起来会很卡，毕竟不停的筛选、复制、新建工作簿、改名字、打开、粘贴，保存关闭等操作嘛！ 我更喜欢的方法是，把 A列和C列的值合并在一起写入字典 ，这样就可以知道到底有哪些类别了，而且避免了不必要的筛选，比如：菜市场1对应的没有花菜，那就不必须筛选菜市场1，然后再筛选花菜了。 然后把每一行的数据合并后写入到一个数组中，这样这个数组就是一维数组，可以直接进行筛选，筛选的关键是通过拆分字典中每个key得到，经过两次筛选就得到了想要的数据。 比如筛选菜市场1就得到了所有菜市场1的数据，在筛选后的结果中再筛选花生就会得到菜市场1中花生的数据，把这个数据放入一个新的工作簿，然后继续循环…… 啰里啰嗦了一堆，也许还有人看不大懂，所以学习VBA一定动手写，然后再参考别人的代码，总结并吸收不同的思路。 当然此案例还有其它思路，大家可以多发散思考下。 具体代码如下：

Sub 筛选数据()    Dim sh As Worksheet    Dim arr, d As Object, i As Long    Dim row1 As Long, col1 As Long, arr1(), n1 As Long, n2 As Long, str$    Dim arr2, n3 As Long, c1$, c2$, arr3, arr4, arr5, n4 As Long, n5 As Long    Dim pah$        '关闭系统提示    Application.DisplayAlerts = False        '把数据区域读取到arr中    arr = Sheets(1).[a1].CurrentRegion        '创建一个字典d，把A列和C列不重复的筛选条件合并写入到字典中    Set d = CreateObject("scripting.dictionary")    For i = 1 To UBound(arr)        d(arr(i, 1) & "," & arr(i, 3)) = ""    Next        '把数据区域每一行连接在一起写入数组arr1中，以便在其中进行筛选    row1 = UBound(arr)    col1 = UBound(arr, 2)    ReDim arr1(1 To row1)    For n1 = 1 To row1        For n2 = 1 To col1            str = str & "," & arr(n1, n2)        Next n2        arr1(n1) = Right(str, Len(str) - 1)        str = ""    Next n1     '拆分筛选条件并在arr1中筛选出符合条件的记录    arr2 = d.keys    For n3 = 0 To d.Count - 1        c1 = Split(arr2(n3), ",")(0)        c2 = Split(arr2(n3), ",")(1)        arr3 = Filter(arr1, c1)        arr4 = Filter(arr3, c2)                '把符合条件的记录放到新工作簿中        ReDim arr5(0 To UBound(arr4), 0 To UBound(arr, 2) - 1)        For n4 = 0 To UBound(arr4)            For n5 = 0 To UBound(arr, 2) - 1                arr5(n4, n5) = Split(arr4(n4), ",")(n5)            Next n5        Next n4                pah = ThisWorkbook.Path        Workbooks.Add.SaveAs pah & "\" & Split(arr2(n3), ",")(0) & "+" & Split(arr2(n3), ",")(1)        ActiveSheet.[a1].Resize(UBound(arr5) + 1, UBound(arr5, 2) + 1) = arr5        ActiveWorkbook.Close 1                '清空arr3 , arr4, arr5以备下次装入数据        Erase arr3        Erase arr4        Erase arr5            Next n3    '释放字典对象    Set d = Nothing        '打开系统提示     Application.DisplayAlerts = True          '激活数据源表     Sheets(1).Activate     End Sub

向右滑动可以查看完整代码。 代码中每段都要提示，懂VBA基础的同学应该能看懂。

本节的分享就到这里，祝大家每天都有进步。

1

在线课堂在逐渐完善中，欢迎您的光临！

点击下方“”了解更多VBA的知识！