急！求助用VBA提取不重复值

lin68 · 发表于 2010-3-18 18:46

各位大侠：
我的工作表因商品名称太多，用函数公式提取不重复值的计算速度太慢，请大侠帮帮用VBA提取不重复值（急用），内容见附件，谢谢！

lb_bn · 发表于 2010-3-18 19:09

Sub bbb()
Dim i&, ir, arr1(), sh As Object, dic1 As Object

Set dic1 = CreateObject("scripting.dictionary")
For Each sh In ThisWorkbook.Sheets
      If sh.Name Like "*月" Then
         ir = sh.[b65536].End(3).Row
         If ir = 6 Then dic1(sh.[b6].Value) = ""
         If ir > 6 Then
            arr1 = sh.[b6].Resize(ir - 5).Value
            For i = 1 To UBound(arr1)
                  dic1(arr1(i, 1)) = ""
            Next
         End If
      End If
Next

dic1.Remove ""
With Sheets("汇总")
      If dic1.Count = 0 Then Exit Sub
      .[b5].Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
End With
End Sub

lin68 · 发表于 2010-3-18 19:40

请再帮一下：
1. 汇总表提取重复值时要先清空B列的商品名称
2. 各月份工作表的也要写一个宏，从H列和K列提取不重复值到B列，先清空B列商品名称再提取重复值。
谢谢！

lin68 · 发表于 2010-3-18 20:19

大侠：
帮一下吧，我等这个表用。谢谢！

figfig · 发表于 2010-3-18 21:04

原帖由 lin68 于 2010-3-18 19:40 发表
请再帮一下：
2. 各月份工作表的也要写一个宏，从H列和K列提取不重复值到B列，先清空B列商品名称再提取重复值。
谢谢！

Sub FIGJS()

Set x = CreateObject("SCRIPTCONTROL")
x.Language = "JSCRIPT"

For Each Sht In ThisWorkbook.Sheets

If Sht.Name <> "汇总" Then

Set arr = x.eval("new Array()")
Sht.[b6:b8888] = Empty

For i = 6 To 888
If InStr(arr & ",", Sht.Cells(i, "f") & ",") = 0 Then

arr.push Sht.Cells(i, "f").Value

End If

Next
For i = 6 To 888
If InStr(arr & ",", Sht.Cells(i, "k") & ",") = 0 Then

arr.push Sht.Cells(i, "k").Value

End If

Next

Sht.[b6].Resize(UBound(Split(arr, ",")) + 1, 1) = Application.Transpose(Split(arr, ","))

End If
Next

lb_bn · 发表于 2010-3-18 21:09

Sub bbb()
Dim i&, ii&, ir&, arr1(), arr2(), sh As Object, dic1 As Object, dic2 As Object

Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")

arr2 = Array("f", "k")
For Each sh In ThisWorkbook.Sheets
      If sh.Name Like "*月" Then
         For i = 0 To UBound(arr2)
            ir = sh.Cells(65536, arr2(i)).End(3).Row
            If ir = 6 Then
                  dic2(sh.Cells(6, arr2(i)).Value) = ""
                  dic1(sh.Cells(6, arr2(i)).Value) = ""
            End If
            If ir > 6 Then
                  arr1 = sh.Cells(6, arr2(i)).Resize(ir - 5).Value
                  For ii = 1 To UBound(arr1)
                     dic2(arr1(ii, 1)) = ""
                     dic1(arr1(ii, 1)) = ""
                  Next
            End If
         Next
         If dic2.Count > 0 Then
            sh.[b6:b65536].ClearContents
            sh.[b6].Resize(dic2.Count).Value = Application.Transpose(dic2.keys)
            dic2.RemoveAll
         End If
      End If
Next

With Sheets("汇总")
      If dic1.Count = 0 Then Exit Sub
      .[b5:b65536].ClearContents
      .[b5].Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
End With
End Sub

lin68 · 发表于 2010-3-18 22:05

谢谢5楼和6楼二位大侠
5楼大侠的宏代码运行时显示类型不匹配，如何处理？

		自动登录	找回密码
密码			免费注册

急！求助用VBA提取不重复值

lb-bn你好！

浏览过的版块