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

lin68

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

lb_bn

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

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

lin68

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

figfig

原帖由 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

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

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