提取多个工作表不重复数据

yeling922 · 发表于 2016-4-9 13:54

实现功能：
1、提取“姓名a-e”表（可能会更多）的B列从第四行开始的工具名称，去除重复项，汇总到“汇总”表的B列中显示出来；
2、计算相对应的工具使用数量合计，显示在C列；
3、显示工具对应的单价成本，显示在D列；
其余列不动
求破解！

cbtaja · 发表于 2016-4-9 14:50

Sub cs()
Dim arr(1 To 999, 1 To 4)
With Sheet1.UsedRange.Resize(, 3).Offset(2, 1)
.ClearContents
aa = .Value
End With
Set dic = CreateObject("scripting.dictionary")
For Each sh In Sheets
If sh.Name Like "姓名*" Then
With sh
tmp = .UsedRange.Offset(3, 1).Resize(, 34)
For i = 1 To UBound(tmp) - 3
If Len(tmp(i, 1)) Then
If dic.exists(tmp(i, 1)) Then
p = dic(tmp(i, 1))
Else
n = n + 1
dic(tmp(i, 1)) = n
p = n
arr(p, 1) = tmp(i, 1) '名称
arr(p, 3) = tmp(i, 34) '单价
End If
For j = 2 To 32
arr(p, 2) = arr(p, 2) + tmp(i, j) '数量累计
Next
End If
Next
End With
End If
Next
For i = 1 To n
arr(i, 4) = arr(i, 2) * arr(i, 3) '总价
Next
Sheet1.[b3].Resize(n, 4) = arr
End Sub

复制代码

yeling922 · 发表于 2016-4-9 14:57

cbtaja 发表于 2016-4-9 14:50

“姓名*”的工作表会改成名字，不一定是从a-z什么的，也可以用这个编码吗？

一指禅62 · 发表于 2016-4-9 15:07

本帖最后由一指禅62 于 2016-4-9 20:28 编辑

Sub 成本汇总()
Dim Sh As Worksheet, d As Object, arr(), i%, m%, n%
Set d = CreateObject("Scripting.Dictionary")
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "经销店汇总" And Sh.Name <> "基础数据维护" And Sh.Name <> "油漆出库" Then
For i = 4 To Sh.Range("B65536").End(3).Row
If Sh.Range("B" & i) <> 0 Then
If Not d.Exists(Sh.Range("B" & i).Value) Then
m = m + 1: ReDim Preserve arr(1 To 2, 1 To m)
d.Add Sh.Range("B" & i).Value, m
arr(1, m) = Sh.Range("AH" & i).Value
arr(2, m) = Sh.Range("AI" & i).Value
Else
n = d(Sh.Range("B" & i).Value)
arr(1, n) = arr(1, n) + Sh.Range("AH" & i).Value
' arr(2, n) = arr(2, n) + Sh.Range("AI" & i).Value
End If
End If
Next
End If
Next
With Sheet1
.Range("B3:D65536").ClearContents
.Range("B3").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
.Range("C3").Resize(d.Count, 2) = WorksheetFunction.Transpose(arr)
End With
Set Sh = Nothing
Set d = Nothing
End Sub

复制代码

一指禅62 · 发表于 2016-4-9 15:10

本帖最后由一指禅62 于 2016-4-9 20:25 编辑

请测试

成本统计表.rar (115.67 KB, 下载次数: 259)

另外，建议楼主学习一些关于数据管理方面的知识，优化数据管理。

yeling922 · 发表于 2016-4-9 16:06

一指禅62 发表于 2016-4-9 15:10
请测试

已经测试使用，功能都能实现，还有两个问题：
1、单件成本（D列），不需要做累加的，只是显示其中一件的成本即可，如何修改；
2、为什么不停的按按钮汇总的时候，汇总的项目一直在滚动刷新？

cbtaja · 发表于 2016-4-9 16:34

yeling922 发表于 2016-4-9 14:57
“姓名*”的工作表会改成名字，不一定是从a-z什么的，也可以用这个编码吗？

这是为了让代码能自动区分出姓名表格与其它表格，在每个人的表格姓名前加上一个相同的识别字符如“姓名”，这样，代码就会自动处理所有以“姓名“打头的工作表。

如果你在工作表命名时候添加的识别字符为“xm”，则代码中相应改为 "xm*"即可。

一指禅62 · 发表于 2016-4-9 20:27

yeling922 发表于 2016-4-9 16:06
已经测试使用，功能都能实现，还有两个问题：
1、单件成本（D列），不需要做累加的，只是显示其中一件的 ...

关于第一个问题，5楼已更新，请重新下载测试。

关于第二个问题，我不明白是什么意思。

yeling922 · 发表于 2016-6-13 15:25

一指禅62 发表于 2016-4-9 20:27
关于第一个问题，5楼已更新，请重新下载测试。

关于第二个问题，我不明白是什么意思。

附件的表是这个帖子之前的问题表格，已经使用你给我做的程序使用了一段时间，我也根据自己需要改过，但是不知哪里出错了，我自己实在是找不出来原因，基础数据表里面只要物料什么都是空的，点击按钮就出错，哪怕是录入一行也没问题，就是基础数据这个表不能随便增减行，也不能为空，就连表头也不能改，不然一点按钮就出错，麻烦帮我再看看，谢谢！

一指禅62 · 发表于 2016-6-14 14:35

yeling922 发表于 2016-6-13 15:25
附件的表是这个帖子之前的问题表格，已经使用你给我做的程序使用了一段时间，我也根据自己需要改过，但是 ...

Sub 成本汇总()
Dim Sh As Worksheet, d As Object, arr(), i%, m%, n%
Set d = CreateObject("Scripting.Dictionary")
For Each Sh In ThisWorkbook.Sheets
      If Sh.Name <> "辅料成本汇总表" And Sh.Name <> "基础数据维护" Then
         For i = 4 To Sh.Range("B65536").End(3).Row
            If Sh.Range("B" & i) <> 0 Then
                  If Not d.Exists(Sh.Range("B" & i).Value) Then
                     m = m + 1: ReDim Preserve arr(1 To 2, 1 To m)
                     d.Add Sh.Range("B" & i).Value, m
                     arr(1, m) = Sh.Range("AH" & i).Value
                     arr(2, m) = Sh.Range("AI" & i).Value
                  Else
                     n = d(Sh.Range("B" & i).Value)
                     arr(1, n) = arr(1, n) + Sh.Range("AH" & i).Value
                     'arr(2, n) = arr(2, n) + Sh.Range("AI" & i).Value
                  End If
            End If
         Next
      End If
Next
With Sheet1
      .Range("B4:D65536").ClearContents
      If m > 0 Then
         .Range("B4").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
         .Range("C4").Resize(d.Count, 2) = WorksheetFunction.Transpose(arr)
      End If
End With
Set Sh = Nothing
Set d = Nothing
End Sub

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

[求助] 提取多个工作表不重复数据