下面表格数据用vba怎么实现

dong130

第一步在sheet2中统计shee1中B列为Parent和为空时A列品牌出现的个数。

第二步：在sheet1中党A列品牌一样时，其他Parent归属下的系列都删除，只保留一个Parent归属下的系列（随机删除其他Parent归属下系列的行）。直接在原来区域删除行（因为D列之后还有很多对应的数据没有列举放在表格里）；
如果B列为空时，A列品牌也有重复的，也是直接删除行其他只保留一条。

taller

1. Option Explicit
   
2. Sub Demo()
   
3.     Dim objDic As Object, rngData As Range, rngDel As Range
   
4.     Dim i As Long, sKey As String, j As Long
   
5.     Dim arrData, bDel As Boolean
   
6.     Dim oSht1 As Worksheet, oSht2 As Worksheet
   
7.     Set oSht1 = Sheets("Sheet1")
   
8.     Set oSht2 = Sheets("Sheet2")
   
9.     Set objDic = CreateObject("scripting.dictionary")
   
10.     Set rngData = oSht1.Range("A1").CurrentRegion
    
11.     arrData = rngData.Value
    
12.     For i = LBound(arrData) + 1 To UBound(arrData)
    
13.         sKey = arrData(i, 1)
    
14.         If arrData(i, 2) = "Parent" Or Len(arrData(i, 2)) = 0 Then
    
15.             If objDic.exists(sKey) Then
    
16.                 objDic(sKey) = objDic(sKey) + 1
    
17.             Else
    
18.                 objDic(sKey) = 1
    
19.             End If
    
20.         End If
    
21.     Next i
    
22.     oSht2.Range("A1:B1") = Array("品牌", "计数项")
    
23.     oSht2.Range("A2").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
    
24.     oSht2.Range("B2").Resize(objDic.Count, 1) = Application.Transpose(objDic.items)
    
25.     objDic.RemoveAll
    
26.     For i = LBound(arrData) + 1 To UBound(arrData)
    
27.         sKey = arrData(i, 1)
    
28.         If arrData(i, 2) = "Parent" Or Len(arrData(i, 2)) = 0 Then
    
29.             If Not objDic.exists(sKey) Then
    
30.                 objDic(sKey) = 1
    
31.                 bDel = False
    
32.             Else
    
33.                 bDel = True
    
34.             End If
    
35.             j = i
    
36.             Do
    
37.                 If bDel Then
    
38.                     If rngDel Is Nothing Then
    
39.                         Set rngDel = oSht1.Cells(j, 1)
    
40.                     Else
    
41.                         Set rngDel = Application.Union(rngDel, oSht1.Cells(j, 1))
    
42.                     End If
    
43.                 End If
    
44.                 If j = UBound(arrData) Then Exit Do
    
45.                 j = j + 1
    
46.             Loop Until arrData(j, 2) = "Parent" Or Len(arrData(j, 2)) = 0
    
47.             If j < UBound(arrData) Then i = j - 1
    
48.         End If
    
49.     Next
    
50.     If Not rngDel Is Nothing Then
    
51.         Debug.Print rngDel.Address
    
52.         rngDel.EntireRow.Delete
    
53.     End If
    
54. End Sub
    

复制代码

quqiyuan

参与一下，本代码适合关键字是按照目前的排列，不能穿插。实现当前的功能吧。。。

quqiyuan

代码如下。。
Sub test()
    arr = Sheet1.[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If arr(i, 2) = "Parent" Or arr(i, 2) = Empty Then
            s = arr(i, 1) & "Parent"
            d(arr(i, 1)) = d(arr(i, 1)) + 1
            If Not dic.exists(arr(i, 1)) Then Set dic(arr(i, 1)) = CreateObject("scripting.dictionary")
            dic(arr(i, 1))(i) = i
        End If
    Next
    Sheet2.[e2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    k = d.keys
    n = UBound(arr)
    For i = d.Count - 1 To 0 Step -1
        item_2 = dic(k(i)).items
        For j = dic(k(i)).Count - 1 To 1 Step -1
            m = dic(k(i))(item_2(j))
            Sheet1.Cells(m, 1).Resize(n - m + 1).EntireRow.Delete
            n = m - 1
        Next
        n = dic(k(i))(item_2(0)) - 1
    Next
    Set d = Nothing
    Set dic = Nothing
    Beep
End Sub

rym9401

PQ做了一个。

dong130

quqiyuan 发表于 2024-6-18 14:31
代码如下。。
Sub test()
    arr = Sheet1.[a1].CurrentRegion

你好，问下，为什么我把品牌列调到后面去，模仿你这个代码就出现了错误：运行是错误‘5’  无效的过程调用或参数

dong130

taller 发表于 2024-6-18 11:25

感谢，但为什么我把品牌放到第七列后，前面内容往A列挪后，改了代码的单元格位置后，就不行了

半百

请测试

1. Sub test()
   
2. arr = Sheets(1).[a1].CurrentRegion
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. For i = 2 To UBound(arr)
   
6.     s = arr(i, 1) & "|" & arr(i, 2)
   
7.     If arr(i, 2) = "Parent" Or arr(i, 2) = "" Then
   
8.         d(arr(i, 1)) = d(arr(i, 1)) + 1
   
9.         d1(s) = d1(s) + 1
   
10.         If d1(s) > 1 Then ss = ss & "," & "a" & i
    
11.     Else
    
12.         If d1(arr(i, 1) & "|Parent") > 1 Or d1(arr(i, 1) & "|") > 1 Then ss = ss & "," & "a" & i
    
13.     End If
    
14. Next
    
15. Sheets(2).[d2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
16. Sheets(1).Range(Mid(ss, 2)).EntireRow.Delete
    
17. End Sub
    

复制代码

quqiyuan

dong130 发表于 2024-6-18 16:07
你好，问下，为什么我把品牌列调到后面去，模仿你这个代码就出现了错误：运行是错误‘5’  无效的过程调 ...

就这样看，感觉正常哦，但是没有看到数据不好说

usedrange

1. Sub t()
   
2.     Dim arr, brr, m%, i%, j%, dic, k, n%, p, r%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     m = Sheet1.Range("a2").End(4).Row
   
5.     arr = Sheet1.Range("a2:b" & m)
   
6.     ReDim p(1 To m)
   
7.     j = 1
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 2) = "Parent" Or arr(i, 2) = "" Then
   
10.             dic(arr(i, 1)) = dic(arr(i, 1)) + 1
    
11.         End If
    
12.     Next i
    
13.     n = 2
    
14.     For Each k In dic.keys
    
15.         Sheet2.Cells(n, 3) = k
    
16.         Sheet2.Cells(n, 4) = dic(k)
    
17.         n = n + 1
    
18.     Next k
    
19.     dic.RemoveAll
    
20.     With Sheet1
    
21.         For i = 1 To UBound(arr)
    
22.             If arr(i, 2) = "Parent" Or arr(i, 2) = "" Then
    
23.                 dic(arr(i, 1)) = dic(arr(i, 1)) + 1
    
24.                 If dic(arr(i, 1)) > 1 Then
    
25.                     x = i + 1
    
26.                     While .Cells(x, 1) = arr(i, 1)
    
27.                         p(j) = .Cells(x, 1).Row
    
28.                         x = x + 1: j = j + 1
    
29.                     Wend
    
30.                     i = x - 2
    
31.                 End If
    
32.             End If
    
33.         Next i
    
34.         For i = UBound(p) To 1 Step -1
    
35.             If p(i) <> 0 Then
    
36.                 Rows(p(i)).Delete shift:=xlUp
    
37.             End If
    
38.         Next i
    
39.     End With
    
40.     Set dic = Nothing
    
41. End Sub
    

复制代码