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

dong130 · 发表于 2024-6-18 10:51

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

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

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

Option Explicit
Sub Demo()
Dim objDic As Object, rngData As Range, rngDel As Range
Dim i As Long, sKey As String, j As Long
Dim arrData, bDel As Boolean
Dim oSht1 As Worksheet, oSht2 As Worksheet
Set oSht1 = Sheets("Sheet1")
Set oSht2 = Sheets("Sheet2")
Set objDic = CreateObject("scripting.dictionary")
Set rngData = oSht1.Range("A1").CurrentRegion
arrData = rngData.Value
For i = LBound(arrData) + 1 To UBound(arrData)
sKey = arrData(i, 1)
If arrData(i, 2) = "Parent" Or Len(arrData(i, 2)) = 0 Then
If objDic.exists(sKey) Then
objDic(sKey) = objDic(sKey) + 1
Else
objDic(sKey) = 1
End If
End If
Next i
oSht2.Range("A1:B1") = Array("品牌", "计数项")
oSht2.Range("A2").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
oSht2.Range("B2").Resize(objDic.Count, 1) = Application.Transpose(objDic.items)
objDic.RemoveAll
For i = LBound(arrData) + 1 To UBound(arrData)
sKey = arrData(i, 1)
If arrData(i, 2) = "Parent" Or Len(arrData(i, 2)) = 0 Then
If Not objDic.exists(sKey) Then
objDic(sKey) = 1
bDel = False
Else
bDel = True
End If
j = i
Do
If bDel Then
If rngDel Is Nothing Then
Set rngDel = oSht1.Cells(j, 1)
Else
Set rngDel = Application.Union(rngDel, oSht1.Cells(j, 1))
End If
End If
If j = UBound(arrData) Then Exit Do
j = j + 1
Loop Until arrData(j, 2) = "Parent" Or Len(arrData(j, 2)) = 0
If j < UBound(arrData) Then i = j - 1
End If
Next
If Not rngDel Is Nothing Then
Debug.Print rngDel.Address
rngDel.EntireRow.Delete
End If
End Sub

复制代码

quqiyuan · 发表于 2024-6-18 14:30

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

quqiyuan · 发表于 2024-6-18 14:31

代码如下。。
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 · 发表于 2024-6-18 15:21

PQ做了一个。

dong130 · 发表于 2024-6-18 16:07

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

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

dong130 · 发表于 2024-6-18 16:09

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

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

半百 · 发表于 2024-6-18 17:14

请测试

Sub test()
arr = Sheets(1).[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
s = arr(i, 1) & "|" & arr(i, 2)
If arr(i, 2) = "Parent" Or arr(i, 2) = "" Then
d(arr(i, 1)) = d(arr(i, 1)) + 1
d1(s) = d1(s) + 1
If d1(s) > 1 Then ss = ss & "," & "a" & i
Else
If d1(arr(i, 1) & "|Parent") > 1 Or d1(arr(i, 1) & "|") > 1 Then ss = ss & "," & "a" & i
End If
Next
Sheets(2).[d2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
Sheets(1).Range(Mid(ss, 2)).EntireRow.Delete
End Sub

复制代码

quqiyuan · 发表于 2024-6-18 18:10

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

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

usedrange · 发表于 2024-6-18 18:21

Sub t()
Dim arr, brr, m%, i%, j%, dic, k, n%, p, r%
Set dic = CreateObject("scripting.dictionary")
m = Sheet1.Range("a2").End(4).Row
arr = Sheet1.Range("a2:b" & m)
ReDim p(1 To m)
j = 1
For i = 1 To UBound(arr)
If arr(i, 2) = "Parent" Or arr(i, 2) = "" Then
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
End If
Next i
n = 2
For Each k In dic.keys
Sheet2.Cells(n, 3) = k
Sheet2.Cells(n, 4) = dic(k)
n = n + 1
Next k
dic.RemoveAll
With Sheet1
For i = 1 To UBound(arr)
If arr(i, 2) = "Parent" Or arr(i, 2) = "" Then
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
If dic(arr(i, 1)) > 1 Then
x = i + 1
While .Cells(x, 1) = arr(i, 1)
p(j) = .Cells(x, 1).Row
x = x + 1: j = j + 1
Wend
i = x - 2
End If
End If
Next i
For i = UBound(p) To 1 Step -1
If p(i) <> 0 Then
Rows(p(i)).Delete shift:=xlUp
End If
Next i
End With
Set dic = Nothing
End Sub

复制代码

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