怎么用数组或字典去除重复并归类.

tigertc · 发表于 2019-3-11 19:51

请教老师,怎么用数组或字典去除重复并归类.

主料	次料1	次料2	次料3	次料4	次料5	次料6	次料7	次料8
AA	AA	AA2	AA3	AA4	AA5	AA6	AA7	AA8
BB	BB	BB2	BB3	BB4	BB5	AA2
CC	CC	CC2	CC3	EE3	EE40
CC	CC	CC4	CC6	CC8
EE	EE	EE2	EE3	EE40
GG	GG	GG8	GG10
GG	GG	GG1	GG2	GG3	GG4
AA	AA	AA4	AA9	AA10	AA2	AA6
BB	BB	BB10	BB11	BB1	BB2

1.在A列找出相同数据并把A列后面的数据合并到一行,并去除此行的重复.最终结果是A列没有重复的.
2.因为把A列重复的合并成一行了,那空行要删除.
3.将每行中的单元格与其它行的单元格对比,如果有相同的就归为一类.如BB行中有AA2这个值是和AA行有相同单元格所以是一类.

因为自己写了代码但没有数组和字典,运行很慢,求助老师看看怎么处理...

duquancai · 发表于 2019-3-11 20:07

第三步有逻辑错误！！！

tigertc · 发表于 2019-3-11 20:40

duquancai 发表于 2019-3-11 20:07
第三步有逻辑错误！！！

没有错误,数据是测试数据,我取名AA/BB/CC/DD/AA1/AA3....实际是很长不相同不相似的数据.

tigertc · 发表于 2019-3-11 20:44

Sub a依主料合并()
Dim rng1, rng2 As Range, addr$, adr$
Dim i As Long, j As Byte, k As Byte
Application.ScreenUpdating = False
For i = 2 To Range("A1048576").End(xlUp).Row
If Cells(i, 1) <> "" Then
Set rng1 = Range("a:a").Find(Cells(i, 1).Value, lookat:=xlWhole)
addr = rng1.Address '第一个地址是addr
Do
Set rng1 = Range("a:a").FindNext(rng1)
adr = rng1.Address '下一个的地址是adr
If adr <> addr Then
For j = 1 To 10
k = Application.WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, Cells(i, 16384).End(xlToLeft).Column)), Cells(rng1.Row, j))
If Cells(rng1.Row, j) = "" Then
Else
If k > 0 Then
Cells(rng1.Row, j).Clear
Else
Cells(i, Cells(i, 16384).End(xlToLeft).Column + 1) = Cells(rng1.Row, j)
Cells(i, Cells(i, 16384).End(xlToLeft).Column).Interior.ColorIndex = 3
Cells(rng1.Row, j).Clear
End If
End If
Next j
End If
Loop Until adr = addr
End If
Next i
Application.ScreenUpdating = True
MsgBox "完成"
End Sub
Sub b去空行()
Dim i As Long
Application.ScreenUpdating = False
For i = Range("A1048576").End(xlUp).Row To 2 Step -1
If Cells(i, 1) = "" Then
Rows(i).Delete shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
MsgBox "完成"
End Sub
Sub c开始分类()
Dim rng1 As Range, addr As String, adr As String
Dim i As Long, j As Byte, n As Integer, k As Byte
n = 1
k = Columns(InputBox("最后一个次料列标是:")).Column
Application.ScreenUpdating = False
For i = 2 To Range("A1048576").End(xlUp).Row
For j = 1 To k
If Cells(i, j) <> "" Then
Set rng1 = Range(Cells(2, 1), Cells(Range("A1048576").End(xlUp).Row, k)).Find(Cells(i, j).Value, lookat:=xlWhole)
addr = rng1.Address
If Cells(rng1.Row, k + 1) = "" Then
Cells(rng1.Row, k + 1) = n
n = n + 1
End If
Do
Set rng1 = Range(Cells(2, 1), Cells(Range("A1048576").End(xlUp).Row, k)).FindNext(rng1)
adr = rng1.Address
If adr <> addr Then
If Cells(rng1.Row, k + 1) = "" Then
Cells(rng1.Row, k + 1) = Cells(Range(addr).Row, k + 1)
Else
If Cells(rng1.Row, k + 1) <> Cells(Range(addr).Row, k + 1) Then
Cells(rng1.Row, k + 1).Interior.ColorIndex = 3
MsgBox "可能是多方,已标记红底色!"
End If
End If
End If
Loop Until addr = adr
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

复制代码

这是原来写的代码,但数据量大时运行过慢,所以求数组或字典的解决办法,供参考逻辑.

duquancai · 发表于 2019-3-11 20:45

tigertc 发表于 2019-3-11 20:40
没有错误,数据是测试数据,我取名AA/BB/CC/DD/AA1/AA3....实际是很长不相同不相似的数据.

好的，等待后面大神吧！

chxw68 · 发表于 2019-3-11 21:24

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("原数据")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a2").Resize(r - 1, c)
End With
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
For j = 2 To UBound(arr, 2)
If Len(arr(i, j)) <> 0 Then
d(arr(i, 1))(arr(i, j)) = ""
End If
Next
Next
kk = d.keys
k = 0
For i = 0 To UBound(kk)
If Not d1.exists(kk(i)) Then
k = k + 1
d1(kk(i)) = k
For j = i + 1 To UBound(kk)
If Not d1.exists(d(kk(j))) Then
For Each bb In d(kk(j)).keys
If d(kk(i)).exists(bb) Then
d1(kk(j)) = k
Exit For
End If
Next
End If
Next
End If
Next
s = 0
For Each aa In d.keys
If s < d(aa).Count Then
s = d(aa).Count
End If
Next
With Worksheets("结果")
.Cells.Clear
.Cells(1, 1) = "主料"
For j = 1 To s
.Cells(1, j + 1) = "次料" & j
Next
.Cells(1, s + 2) = "编码"
m = 2
For Each aa In d.keys
.Cells(m, 1) = aa
.Cells(m, 2).Resize(1, d(aa).Count) = d(aa).keys
.Cells(m, s + 2) = d1(aa)
m = m + 1
Next
End With
End Sub

复制代码

chxw68 · 发表于 2019-3-11 21:25

以前没有做过这样的题目，练练手。

tigertc · 发表于 2019-3-11 21:32

本帖最后由 tigertc 于 2019-3-11 21:41 编辑

chxw68 发表于 2019-3-11 21:24

感谢褚老师,我研究下.

张道贤 · 发表于 2019-3-11 22:38

用得最多的就是循环和字典，只是第三部的编码没搞懂是从数据源的什么地方来的………………

Sub 去重组合()
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
arr = Sheet1.[A1].CurrentRegion
For i = 2 To UBound(arr)
If d.exists(arr(i, 1)) Then cl = d(arr(i, 1)) Else cl = ""
For j = 2 To UBound(arr, 2)
If arr(i, j) <> "" _
Then If cl = "" Then cl = arr(i, j) _
Else cl = cl & "," & arr(i, j)
Next j: d(arr(i, 1)) = cl
Next i
For Each da In d: arr = Split(d(da), ",")
For i = 0 To UBound(arr)
If Not ds.exists(arr(i)) Then ds(arr(i)) = arr(i)
Next i
d(da) = Application.Index(ds.Items, 0): ds.RemoveAll
Next da
For Each sh In Sheets
If sh.Name = "返回结果" Then shz = "存在": Exit For
Next sh
If shz <> "存在" _
Then Sheets.Add after:=Sheets(Sheets.Count): Sheets(Sheets.Count).Name = "返回结果" _
Else Sheets("返回结果").[A1].CurrentRegion.ClearContents
With Sheets("返回结果"):
For Each da In d: n = n + 1
If m < UBound(d(da)) Then m = UBound(d(da))
.Cells(n + 1, 1) = da
.Cells(n + 1, 2).Resize(1, UBound(d(da))) = d(da)
Next da
.[A1] = "材料": For j = 2 To m + 1: .Cells(1, j) = "材料" & j - 1: Next j
End With
End Sub

复制代码

山菊花 · 发表于 2019-3-12 10:15

供参考。

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

[求助] 怎么用数组或字典去除重复并归类.

评分

评分

最新热点 /1