利用VBA（宏）对excel里要上架的拼多多商品名称进行批量筛选和归类

一个做电商的用户需要对excel里拟定好的商品名称进行归类，以规避风险和提高竞争优势。

具体操作：

在 筛选词 sheet表先循环每列，再循环每行的数据到 数据 sheet表里进行筛选。

如果 数据 sheet表B列的值包含筛选词，则对B列标红，同时在C列填入筛选词所在列的表头，D列填入该词。

看下面图片（点击可放大）

实际上如果将 筛选词 sheet表的数据都放在一个列里，用vlookup 函数可轻松实现，只是需求变动不了，故用VBA来做。

VBA代码重点：

1，筛选，并把筛选结果保存到临时数组里，

2，通过列位置找到对应列的名称。

全部代码如下：

Sub 筛选并归类()
    Dim s1, s2, i, k, r, j, j_a, m, n, m_n, k_n, k_j
    Dim LastRow As Long
    Dim rng As Range, Rng1 As Range
    
    Set s1 = Sheets("筛选词")
    Set s2 = Sheets("数据")
    k = s1.Range("IV1").End(xlToLeft).Column '获取S1的已用列数
    
    '循环每一列
    For i = 1 To k
        j_a = Chr(i + Asc("A") - 1) '获取S1表的列名
        biaotou = s1.Range(j_a & 1) '获取S1表的首行数据即表头
      
        Set r = s1.Range(j_a & Rows.Count).End(xlUp) '获取S1表的具体列的已用行数
        '循环每一行
        For j = 2 To r.Row
            ci = s1.Range(j_a & j) '获取单元格数据
            Debug.Print ci
            
            With s2
                 .UsedRange
                LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row '返回s2表的最后一行行号
                Set rng = .Range("A1:B" & LastRow) '选中s2表的A-B列全部区域,因为需要A列的序号来区分行号
                rng.AutoFilter Field:=2, Criteria1:="=*" & ci & "*"    '筛选B列包含 ci 的数据
                Set Rng1 = rng.SpecialCells(xlCellTypeVisible) '获取可见行数据（筛选结果)
                'Debug.Print Rng1.Areas(1, 1)
                If Rng1.Areas.Count > 1 Then
                    m = 1
                    lc = Rng1.Columns.Count
                    lr = Rng1.Cells.Count / lc
                    Debug.Print lc
                    Debug.Print Rng1.Cells.Count
                    '准备个数组
                    Dim arr()
                    ReDim Preserve arr(1 To lr)
    
                    For Each r In Rng1.Areas
                        a = r
                        For m_n = 1 To UBound(a)
                            
                            For k_j = 1 To UBound(a, 2)
                                arr(m) = a(m_n, 1)
                                
                            Next
                            m = m + 1
                        Next
                    Next
                    '循环数组存入的行数
                    Debug.Print UBound(arr, 1)
                    For k_n = 2 To UBound(arr, 1)
                        Number = arr(k_n)
                        .Range("B" & Number).Interior.Color = RGB(255, 0, 0) '匹配到则相应单元格背景色为红
                        .Range("C" & Number) = biaotou
                        .Range("D" & Number) = ci
                Next
                End If
                rng.AutoFilter '关闭自动筛选
                
           End With
        Next
    Next
    MsgBox ("执行完毕！")
End Sub

带数据的xlsm样例文件下载

链接:

https://pan.baidu.com/s/1g5Xn5jRtCk7A_-h55GNqqg