Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2875|回复: 12

[已解决]请问老师我的代码问题在哪里?

[复制链接]
发表于 2015-12-22 10:03 | 显示全部楼层 |阅读模式
各位老师好,我想要实现一个筛选的目的,具体要求如下。
在Templet文件可以看到
1.Code1和Code2这两列任意一列有数据,我就把这一行放入sheet4
如果Code1和Code2如果都无为空则
Name对应的Item如果既有10,又有20的(已经选出,在I列的A,C),
2.如果Item为10并且Code3为XX,放入sheet2
3.如果Item为20,Code3不管是什么都放入sheet3
4.剩下的都放入sheet5

我附件中的另一个ABC文件是代码,Step-1是找出既有10又有20的Name,Step-2就是筛选(一开始筛选不包括上面的4,也就是剩余那部分),但是第四行的第3个A没有进去,请问这是什么原因?Step-3是包含了针对剩余部分筛选的代码,貌似也有问题,请大家帮忙看一下,谢谢。


最佳答案
2015-12-22 11:21
给你一个非常巧妙的方法。
  1. Sub 分类()
  2.     shrr = Array("10", "20", "Code1_Code2", "Other")
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     For i = 0 To UBound(shrr)
  6.         Set d(shrr(i)) = [a1:f1]     '表头
  7.     Next
  8.     arr = Sheets(1).[a1].CurrentRegion
  9.     For i = 2 To UBound(arr)    '字符串累加Name对应的Item
  10.         x = arr(i, 1)
  11.         d1(x) = d1(x) & "," & arr(i, 5)
  12.     Next
  13.    
  14.     For i = 2 To UBound(arr)
  15.         sh = ""
  16.         If Len(arr(i, 3) & arr(i, 4)) Then        'Code1或Code2非空,放入Code1_Code2
  17.             sh = "Code1_Code2"
  18.         Else
  19.             x = arr(i, 1)
  20.             If InStr(d1(x), "10") > 0 And InStr(d1(x), "20") > 0 Then     'Item含10及20对应的Name,放入20
  21.                 If Val(arr(i, 5)) = 20 Then         'Item为20
  22.                     sh = "20"
  23.                 ElseIf Val(arr(i, 5)) = 10 And arr(i, 6) = "XX" Then     'Item为10,Code3为XX,放入10
  24.                     sh = "10"
  25.                 End If
  26.             End If
  27.         End If
  28.         If sh = "" Then sh = "Other"    '如果前面都没有对应上,放入Other
  29.         Set d(sh) = Union(d(sh), Cells(i, 1).Resize(1, 6))   '把当前记录放到对应的工作表名下
  30.     Next
  31.    
  32.     For i = 0 To UBound(shrr)      '各回各家,各找各妈
  33.         With Worksheets(shrr(i))
  34.             .Cells.Clear
  35.             If d.exists(shrr(i)) Then d(shrr(i)).Copy .[a1]
  36.          End With
  37.     Next
  38.     MsgBox "分类完毕!"
  39. End Sub
复制代码

Desktop.zip

29.5 KB, 下载次数: 6

发表于 2015-12-22 10:44 | 显示全部楼层
Templet工作簿中的5张工作表内容是你想要的效果吗?
回复

使用道具 举报

 楼主| 发表于 2015-12-22 10:51 | 显示全部楼层
sry660 发表于 2015-12-22 10:44
Templet工作簿中的5张工作表内容是你想要的效果吗?

2,3,4,5都要,在工作表1中所涂的颜色分配到2,3,4,5里面是我想要实现的
回复

使用道具 举报

 楼主| 发表于 2015-12-22 10:56 | 显示全部楼层
就是说,如果Code1或Code2有一个不为空,这一行数据就要放到sheet4里面,两列都不为空,那么要看Name是否有10和20都有的,比如A,C。而A和C在筛选的时候,要满足1.既是10,Code3又是XX,这些放到sheet2,2.不管Code3是什么,只要是Item是20,要放到sheet3里面,除此以外(Code1,Code2都为空,但是Item没有重复的,比如B,要放到sheet5里面)
回复

使用道具 举报

发表于 2015-12-22 11:21 | 显示全部楼层    本楼为最佳答案   
给你一个非常巧妙的方法。
  1. Sub 分类()
  2.     shrr = Array("10", "20", "Code1_Code2", "Other")
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     For i = 0 To UBound(shrr)
  6.         Set d(shrr(i)) = [a1:f1]     '表头
  7.     Next
  8.     arr = Sheets(1).[a1].CurrentRegion
  9.     For i = 2 To UBound(arr)    '字符串累加Name对应的Item
  10.         x = arr(i, 1)
  11.         d1(x) = d1(x) & "," & arr(i, 5)
  12.     Next
  13.    
  14.     For i = 2 To UBound(arr)
  15.         sh = ""
  16.         If Len(arr(i, 3) & arr(i, 4)) Then        'Code1或Code2非空,放入Code1_Code2
  17.             sh = "Code1_Code2"
  18.         Else
  19.             x = arr(i, 1)
  20.             If InStr(d1(x), "10") > 0 And InStr(d1(x), "20") > 0 Then     'Item含10及20对应的Name,放入20
  21.                 If Val(arr(i, 5)) = 20 Then         'Item为20
  22.                     sh = "20"
  23.                 ElseIf Val(arr(i, 5)) = 10 And arr(i, 6) = "XX" Then     'Item为10,Code3为XX,放入10
  24.                     sh = "10"
  25.                 End If
  26.             End If
  27.         End If
  28.         If sh = "" Then sh = "Other"    '如果前面都没有对应上,放入Other
  29.         Set d(sh) = Union(d(sh), Cells(i, 1).Resize(1, 6))   '把当前记录放到对应的工作表名下
  30.     Next
  31.    
  32.     For i = 0 To UBound(shrr)      '各回各家,各找各妈
  33.         With Worksheets(shrr(i))
  34.             .Cells.Clear
  35.             If d.exists(shrr(i)) Then d(shrr(i)).Copy .[a1]
  36.          End With
  37.     Next
  38.     MsgBox "分类完毕!"
  39. End Sub
复制代码

ABC.rar

26.09 KB, 下载次数: 5

回复

使用道具 举报

 楼主| 发表于 2015-12-22 12:18 | 显示全部楼层
grf1973 发表于 2015-12-22 11:21
给你一个非常巧妙的方法。

感谢您的回复,我测试一下再回复您。字典一直没学好才想着用数组,唉,看来还得努力啊。能指出我代码中的问题么?
回复

使用道具 举报

发表于 2015-12-22 14:44 | 显示全部楼层
step1没什么问题,但可简化
  1. Sub step1()    '找出item为10及20的name,放到I列
  2.     Dim drr(1 To 1000, 1 To 1)
  3.     With Sheets(1)
  4.         arr = .Range("A1").CurrentRegion
  5.         For i = 1 To UBound(arr)
  6.             x = arr(i, 1)
  7.             a = Application.WorksheetFunction.CountIfs(.Range("A:A"), x, .Range("E:E"), "10")
  8.             b = Application.WorksheetFunction.CountIfs(.Range("A:A"), x, .Range("E:E"), "20")
  9.             If a * b > 0 Then
  10.                 k = k + 1
  11.                 drr(k, 1) = x
  12.             End If
  13.         Next i
  14.         .Range("I2").Resize(UBound(drr), 1) = drr
  15.         Range("I:I").RemoveDuplicates Columns:=1, Header:=xlNo
  16.     End With
  17. End Sub
复制代码
回复

使用道具 举报

发表于 2015-12-22 14:45 | 显示全部楼层
step2大大的有问题。按你思路改编了一下,没用字典,希望能看懂。
  1. Sub step2()
  2.     With Sheets(1)
  3.         arr = .Range("A1").CurrentRegion
  4.         xstr = Join(Application.Transpose(.Range("I2:I" & .[I10000].End(xlUp).Row)), "")     'I列的结果,进字符串,以便比较
  5.     End With
  6.    
  7.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  8.     ReDim drr(1 To UBound(arr), 1 To UBound(arr, 2))
  9.     ReDim err(1 To UBound(arr), 1 To UBound(arr, 2))
  10.     ReDim frr(1 To UBound(arr), 1 To UBound(arr, 2))
  11.      
  12.       Dim Flag As Boolean     '判断本行是否已经筛选出
  13.       For i = 2 To UBound(arr)
  14.          Flag = False
  15.          If Len(arr(i, 3) & arr(i, 4)) Then       'code1 code2任一不为空
  16.             Flag = True
  17.             k4 = k4 + 1
  18.             For j = 1 To 6: err(k4, j) = arr(i, j): Next j
  19.         Else
  20.             If InStr(xstr, arr(i, 1)) > 0 Then     '在I列所示的Name中
  21.                 If arr(i, 5) = "20" Then
  22.                     Flag = True
  23.                     k3 = k3 + 1
  24.                     For j = 1 To 6: drr(k3, j) = arr(i, j):  Next j
  25.                 ElseIf arr(i, 5) = "10" And arr(i, 6) = "XX" Then
  26.                     Flag = True
  27.                     k2 = k2 + 1
  28.                     For j = 1 To 6: crr(k2, j) = arr(i, j): Next j
  29.                 End If
  30.             End If
  31.         End If
  32.         If Flag = False Then
  33.             k5 = k5 + 1
  34.             For j = 1 To 6: frr(k5, j) = arr(i, j): Next j
  35.         End If
  36.       Next
  37.      
  38.     Application.DisplayAlerts = False
  39.     shrr = Array("10", "20", "Code1_Code2", "Other")
  40.     On Error Resume Next
  41.     For i = 0 To UBound(shrr)      '生成各工作表,复制表头
  42.         Sheets(shrr(i)).Delete
  43.         Worksheets.Add after:=Sheets(Sheets.Count)
  44.         With ActiveSheet
  45.             .Name = shrr(i)
  46.             .Cells.Clear
  47.             Sheets(1).[a1:f1].Copy .[a1]
  48.          End With
  49.     Next
  50.     Application.DisplayAlerts = True

  51.     Sheets(2).Range("A2").Resize(k2, 6) = crr
  52.     Sheets(3).Range("A2").Resize(k3, 6) = drr
  53.     Sheets(4).Range("A2").Resize(k4, 6) = err
  54.     Sheets(5).Range("A2").Resize(k5, 6) = frr

  55. End Sub
复制代码
回复

使用道具 举报

发表于 2015-12-22 14:47 | 显示全部楼层
两种方法都作了按钮,可比较。

ABC.rar

30.78 KB, 下载次数: 3

回复

使用道具 举报

发表于 2015-12-22 14:50 | 显示全部楼层
另外,代码中arr(i, 5) = "20"这种写法,很容易漏掉。最好转换成同一种数据类型,写成val(arr(i,5))=20     
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 07:24 , Processed in 1.119905 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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