[已解决]遍历多表固定列不重复

张雄友 · 发表于 2014-8-17 12:11

遍历多表固定列不重复。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-8-17 22:06

Sub Macro1()
Dim arr, brr, crr(1 To 60000, 1 To 1), drr(1 To 1000)
Dim s2&, d, d2, w, i%, j&, s&, zf$$
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Sheets("汇总").Activate
For i = 1 To Sheets.Count
If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 0 Then
s = s + 1
arr = Sheets(i).UsedRange
zf = Sheets(i).Name
drr(s) = "仅" & zf & "有"
d2(zf) = s
For j = 2 To UBound(arr)
If arr(j, 1) = "" Then GoTo line1
If Not d.exists(arr(j, 1)) Then
d(arr(j, 1)) = zf
s2 = s2 + 1: crr(s2, 1) = arr(j, 1)
Else
If InStr(d(arr(j, 1)), zf) = 0 Then d(arr(j, 1)) = d(arr(j, 1)) & "," & zf
End If
line1:
Next
End If
Next
ReDim brr(1 To 60000, 1 To s + 1)
ReDim w(1 To s + 1)
a = d.keys: b = d.items
For i = 0 To d.Count - 1
x = Split(b(i), ",")
If UBound(x) = 0 Then
n = d2(b(i))
w(n) = w(n) + 1: brr(w(n), n) = a(i)
End If
If UBound(x) = s - 1 Then w(s + 1) = w(s + 1) + 1: brr(w(s + 1), s + 1) = a(i)
Next
drr(s + 1) = "各表都有": drr(s + 2) = "各表合并不重复"
[a1].Resize(1, s + 2) = drr
Range("a2").Resize(Application.Max(w), s + 1) = brr
Cells(2, s + 2).Resize(s2) = crr
End Sub

复制代码

跳转到最佳答案楼层

旧书重读 · 发表于 2014-8-17 15:12

学习一下

张雄友 · 发表于 2014-8-17 20:18

下载了22个人，有没有哪位大神

dsmch · 发表于 2014-8-17 21:18

Sub Macro1()
Dim arr, brr, d, d2, w, i%, j&, s&, zf$$
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For i = 1 To Sheets.Count
If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 0 Then
s = s + 1
arr = Sheets(i).UsedRange
zf = Sheets(i).Name
d2(zf) = s
For j = 2 To UBound(arr)
If arr(j, 1) = "" Then GoTo line1
If Not d.exists(arr(j, 1)) Then
d(arr(j, 1)) = zf
Else
If InStr(d(arr(j, 1)), zf) = 0 Then d(arr(j, 1)) = d(arr(j, 1)) & "," & zf
End If
line1:
Next
End If
Next
ReDim brr(1 To 60000, 1 To s + 1)
ReDim w(1 To s + 1)
a = d.keys: b = d.items
For i = 0 To d.Count - 1
x = Split(b(i), ",")
If UBound(x) = 0 Then
n = d2(b(i))
w(n) = w(n) + 1: brr(w(n), n) = a(i)
End If
If UBound(x) = s - 1 Then w(s + 1) = w(s + 1) + 1: brr(w(s + 1), s + 1) = a(i)
Next
Sheets("汇总").Activate
Range("a2").Resize(Application.Max(w), s + 1) = brr
Cells(2, s + 2).Resize(d.Count) = Application.Transpose(a)
End Sub

复制代码

dsmch · 发表于 2014-8-17 21:21

………………

张雄友 · 发表于 2014-8-17 21:24

dsmch 发表于 2014-8-17 21:18

第35句，当数据多时会出错。就是不用 transpose.

张雄友 · 发表于 2014-8-17 21:26

dsmch 发表于 2014-8-17 21:18

怎么表头不是自动生成的？当增加表，或者减少表时，就不知是来源于哪个表的了。

张雄友 · 发表于 2014-8-17 21:36

dsmch 发表于 2014-8-17 21:18

第 35 句可不可以像34句这样的表达？还有表头不是自动生成的？

dsmch · 发表于 2014-8-17 21:41

本帖最后由 dsmch 于 2014-8-17 21:42 编辑

Sub Macro1()
Dim arr, brr, crr(1 To 60000, 1 To 1), d, d2, w, i%, j&, s&, zf$$$$$$$$
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Sheets("汇总").Activate
For i = 1 To Sheets.Count
If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 0 Then
s = s + 1
arr = Sheets(i).UsedRange
zf = Sheets(i).Name
Cells(1, s) = "仅" & zf & "有"
d2(zf) = s
For j = 2 To UBound(arr)
If arr(j, 1) = "" Then GoTo line1
If Not d.exists(arr(j, 1)) Then
d(arr(j, 1)) = zf
s2= s2 + 1: crr(s2, 1) = arr(j, 1)
Else
If InStr(d(arr(j, 1)), zf) = 0 Then d(arr(j, 1)) = d(arr(j, 1)) & "," & zf
End If
line1:
Next
End If
Next
ReDim brr(1 To 60000, 1 To s + 1)
ReDim w(1 To s + 1)
a = d.keys: b = d.items
For i = 0 To d.Count - 1
x = Split(b(i), ",")
If UBound(x) = 0 Then
n = d2(b(i))
w(n) = w(n) + 1: brr(w(n), n) = a(i)
End If
If UBound(x) = s - 1 Then w(s + 1) = w(s + 1) + 1: brr(w(s + 1), s + 1) = a(i)
Next
Cells(1, s + 1) = "各表都有": Cells(1, s + 2) = "各表合并不重复"
Range("a2").Resize(Application.Max(w), s + 1) = brr
Cells(2, s + 2).Resize(s2) = crr
End Sub

复制代码

张雄友 · 发表于 2014-8-17 21:55

dsmch 发表于 2014-8-17 21:41

不好意思，再问一下，能不能不用直接操作单元格的方法，

第 11 句，Cells(1, s) = "仅" & zf & "有"
第 36 句，Cells(1, s + 1) = "各表都有": Cells(1, s + 2) = "各表合并不重复"
第 38 句，Cells(2, s + 2).Resize(s2) = crr

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

[已解决]遍历多表固定列不重复

评分

点评